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

! This file was ported from Lean 3 source module data.W.basic
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Equiv.List

/-!
# W types

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

Given `α : Type` and `β : α → Type`, the W type determined by this data, `W_type β`, is the
inductively defined type of trees where the nodes are labeled by elements of `α` and the children of
a node labeled `a` are indexed by elements of `β a`.

This file is currently a stub, awaiting a full development of the theory. Currently, the main result
is that if `α` is an encodable fintype and `β a` is encodable for every `a : α`, then `W_type β` is
encodable. This can be used to show the encodability of other inductive types, such as those that
are commonly used to formalize syntax, e.g. terms and expressions in a given language. The strategy
is illustrated in the example found in the file `prop_encodable` in the `archive/examples` folder of
mathlib.

## Implementation details

While the name `W_type` is somewhat verbose, it is preferable to putting a single character
identifier `W` in the root namespace.
-/

#print WType /-
/--
Given `β : α → Type*`, `W_type β` is the type of finitely branching trees where nodes are labeled by
elements of `α` and the children of a node labeled `a` are indexed by elements of `β a`.
-/
inductive WType {α : Type _} (β : α → Type _)
  | mk (a : α) (f : β a → WType) : WType
#align W_type WType
-/

instance : Inhabited (WType fun _ : Unit => Empty) :=
  ⟨WType.mk Unit.unit Empty.elim⟩

namespace WType

variable {α : Type _} {β : α → Type _}

#print WType.toSigma /-
/-- The canonical map to the corresponding sigma type, returning the label of a node as an
  element `a` of `α`, and the children of the node as a function `β a → W_type β`. -/
def toSigma : WType β → Σa : α, β a → WType β
  | ⟨a, f⟩ => ⟨a, f⟩
#align W_type.to_sigma WType.toSigma
-/

#print WType.ofSigma /-
/-- The canonical map from the sigma type into a `W_type`. Given a node `a : α`, and
  its children as a function `β a → W_type β`, return the corresponding tree. -/
def ofSigma : (Σa : α, β a → WType β) → WType β
  | ⟨a, f⟩ => WType.mk a f
#align W_type.of_sigma WType.ofSigma
-/

/- warning: W_type.of_sigma_to_sigma -> WType.ofSigma_toSigma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : α -> Type.{u2}} (w : WType.{u1, u2} α β), Eq.{max (succ u1) (succ u2)} (WType.{u1, u2} α (fun (a : α) => β a)) (WType.ofSigma.{u1, u2} α (fun (a : α) => β a) (WType.toSigma.{u1, u2} α β w)) w
but is expected to have type
  forall {α : Type.{u2}} {β : α -> Type.{u1}} (w : WType.{u2, u1} α β), Eq.{max (succ u2) (succ u1)} (WType.{u2, u1} α (fun (a : α) => β a)) (WType.ofSigma.{u2, u1} α (fun (a : α) => β a) (WType.toSigma.{u2, u1} α β w)) w
Case conversion may be inaccurate. Consider using '#align W_type.of_sigma_to_sigma WType.ofSigma_toSigmaₓ'. -/
@[simp]
theorem ofSigma_toSigma : ∀ w : WType β, ofSigma (toSigma w) = w
  | ⟨a, f⟩ => rfl
#align W_type.of_sigma_to_sigma WType.ofSigma_toSigma

/- warning: W_type.to_sigma_of_sigma -> WType.toSigma_ofSigma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : α -> Type.{u2}} (s : Sigma.{u1, max u1 u2} α (fun (a : α) => (β a) -> (WType.{u1, u2} α β))), Eq.{max (succ u1) (succ (max u1 u2))} (Sigma.{u1, max u1 u2} α (fun (a : α) => (β a) -> (WType.{u1, u2} α (fun (a : α) => β a)))) (WType.toSigma.{u1, u2} α (fun (a : α) => β a) (WType.ofSigma.{u1, u2} α (fun (a : α) => β a) s)) s
but is expected to have type
  forall {α : Type.{u2}} {β : α -> Type.{u1}} (s : Sigma.{u2, max u2 u1} α (fun (a : α) => (β a) -> (WType.{u2, u1} α β))), Eq.{max (succ u2) (succ u1)} (Sigma.{u2, max u2 u1} α (fun (a : α) => (β a) -> (WType.{u2, u1} α (fun (a : α) => β a)))) (WType.toSigma.{u2, u1} α (fun (a : α) => β a) (WType.ofSigma.{u2, u1} α (fun (a : α) => β a) s)) s
Case conversion may be inaccurate. Consider using '#align W_type.to_sigma_of_sigma WType.toSigma_ofSigmaₓ'. -/
@[simp]
theorem toSigma_ofSigma : ∀ s : Σa : α, β a → WType β, toSigma (ofSigma s) = s
  | ⟨a, f⟩ => rfl
#align W_type.to_sigma_of_sigma WType.toSigma_ofSigma

variable (β)

#print WType.equivSigma /-
/-- The canonical bijection with the sigma type, showing that `W_type` is a fixed point of
  the polynomial functor `X ↦ Σ a : α, β a → X`. -/
@[simps]
def equivSigma : WType β ≃ Σa : α, β a → WType β
    where
  toFun := toSigma
  invFun := ofSigma
  left_inv := ofSigma_toSigma
  right_inv := toSigma_ofSigma
#align W_type.equiv_sigma WType.equivSigma
-/

variable {β}

#print WType.elim /-
/-- The canonical map from `W_type β` into any type `γ` given a map `(Σ a : α, β a → γ) → γ`. -/
def elim (γ : Type _) (fγ : (Σa : α, β a → γ) → γ) : WType β → γ
  | ⟨a, f⟩ => fγ ⟨a, fun b => elim (f b)⟩
#align W_type.elim WType.elim
-/

/- warning: W_type.elim_injective -> WType.elim_injective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : α -> Type.{u2}} (γ : Type.{u3}) (fγ : (Sigma.{u1, max u2 u3} α (fun (a : α) => (β a) -> γ)) -> γ), (Function.Injective.{max (succ u1) (succ (max u2 u3)), succ u3} (Sigma.{u1, max u2 u3} α (fun (a : α) => (β a) -> γ)) γ fγ) -> (Function.Injective.{max (succ u1) (succ u2), succ u3} (WType.{u1, u2} α (fun (a : α) => β a)) γ (WType.elim.{u1, u2, u3} α (fun (a : α) => β a) γ fγ))
but is expected to have type
  forall {α : Type.{u2}} {β : α -> Type.{u1}} (γ : Type.{u3}) (fγ : (Sigma.{u2, max u1 u3} α (fun (a : α) => (β a) -> γ)) -> γ), (Function.Injective.{max (max (succ u2) (succ u1)) (succ u3), succ u3} (Sigma.{u2, max u1 u3} α (fun (a : α) => (β a) -> γ)) γ fγ) -> (Function.Injective.{max (succ u1) (succ u2), succ u3} (WType.{u2, u1} α (fun (a : α) => β a)) γ (WType.elim.{u2, u1, u3} α (fun (a : α) => β a) γ fγ))
Case conversion may be inaccurate. Consider using '#align W_type.elim_injective WType.elim_injectiveₓ'. -/
theorem elim_injective (γ : Type _) (fγ : (Σa : α, β a → γ) → γ)
    (fγ_injective : Function.Injective fγ) : Function.Injective (elim γ fγ)
  | ⟨a₁, f₁⟩, ⟨a₂, f₂⟩, h =>
    by
    obtain ⟨rfl, h⟩ := Sigma.mk.inj (fγ_injective h)
    congr with x
    exact elim_injective (congr_fun (eq_of_hEq h) x : _)
#align W_type.elim_injective WType.elim_injective

instance [hα : IsEmpty α] : IsEmpty (WType β) :=
  ⟨fun w => WType.recOn w (IsEmpty.elim hα)⟩

#print WType.infinite_of_nonempty_of_isEmpty /-
theorem infinite_of_nonempty_of_isEmpty (a b : α) [ha : Nonempty (β a)] [he : IsEmpty (β b)] :
    Infinite (WType β) :=
  ⟨by
    intro hf
    have hba : b ≠ a := fun h => ha.elim (IsEmpty.elim' (show IsEmpty (β a) from h ▸ he))
    refine'
      not_injective_infinite_finite
        (fun n : ℕ =>
          show WType β from Nat.recOn n ⟨b, IsEmpty.elim' he⟩ fun n ih => ⟨a, fun _ => ih⟩)
        _
    intro n m h
    induction' n with n ih generalizing m h
    · cases' m with m <;> simp_all
    · cases' m with m
      · simp_all
      · refine' congr_arg Nat.succ (ih _)
        simp_all [Function.funext_iff]⟩
#align W_type.infinite_of_nonempty_of_is_empty WType.infinite_of_nonempty_of_isEmpty
-/

variable [∀ a : α, Fintype (β a)]

#print WType.depth /-
/-- The depth of a finitely branching tree. -/
def depth : WType β → ℕ
  | ⟨a, f⟩ => (Finset.sup Finset.univ fun n => depth (f n)) + 1
#align W_type.depth WType.depth
-/

/- warning: W_type.depth_pos -> WType.depth_pos is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : α -> Type.{u2}} [_inst_1 : forall (a : α), Fintype.{u2} (β a)] (t : WType.{u1, u2} α β), LT.lt.{0} Nat Nat.hasLt (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))) (WType.depth.{u1, u2} α β (fun (a : α) => _inst_1 a) t)
but is expected to have type
  forall {α : Type.{u2}} {β : α -> Type.{u1}} [_inst_1 : forall (a : α), Fintype.{u1} (β a)] (t : WType.{u2, u1} α β), LT.lt.{0} Nat instLTNat (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) (WType.depth.{u2, u1} α β (fun (a : α) => _inst_1 a) t)
Case conversion may be inaccurate. Consider using '#align W_type.depth_pos WType.depth_posₓ'. -/
theorem depth_pos (t : WType β) : 0 < t.depth :=
  by
  cases t
  apply Nat.succ_pos
#align W_type.depth_pos WType.depth_pos

/- warning: W_type.depth_lt_depth_mk -> WType.depth_lt_depth_mk is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : α -> Type.{u2}} [_inst_1 : forall (a : α), Fintype.{u2} (β a)] (a : α) (f : (β a) -> (WType.{u1, u2} α β)) (i : β a), LT.lt.{0} Nat Nat.hasLt (WType.depth.{u1, u2} α β (fun (a : α) => _inst_1 a) (f i)) (WType.depth.{u1, u2} α (fun (a : α) => β a) (fun (a : α) => _inst_1 a) (WType.mk.{u1, u2} α (fun (a : α) => β a) a f))
but is expected to have type
  forall {α : Type.{u2}} {β : α -> Type.{u1}} [_inst_1 : forall (a : α), Fintype.{u1} (β a)] (a : α) (f : (β a) -> (WType.{u2, u1} α β)) (i : β a), LT.lt.{0} Nat instLTNat (WType.depth.{u2, u1} α β (fun (a : α) => _inst_1 a) (f i)) (WType.depth.{u2, u1} α β (fun (a : α) => _inst_1 a) (WType.mk.{u2, u1} α β a f))
Case conversion may be inaccurate. Consider using '#align W_type.depth_lt_depth_mk WType.depth_lt_depth_mkₓ'. -/
theorem depth_lt_depth_mk (a : α) (f : β a → WType β) (i : β a) : depth (f i) < depth ⟨a, f⟩ :=
  Nat.lt_succ_of_le (Finset.le_sup (Finset.mem_univ i))
#align W_type.depth_lt_depth_mk WType.depth_lt_depth_mk

/-
Show that W types are encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable.

We define an auxiliary type `W_type' β n` of trees of depth at most `n`, and then we show by
induction on `n` that these are all encodable. These auxiliary constructions are not interesting in
and of themselves, so we mark them as `private`.
-/
@[reducible]
private def W_type' {α : Type _} (β : α → Type _) [∀ a : α, Fintype (β a)]
    [∀ a : α, Encodable (β a)] (n : ℕ) :=
  { t : WType β // t.depth ≤ n }
#align W_type.W_type' W_type.W_type'

variable [∀ a : α, Encodable (β a)]

private def encodable_zero : Encodable (WType' β 0) :=
  let f : WType' β 0 → Empty := fun ⟨x, h⟩ => False.elim <| not_lt_of_ge h (WType.depth_pos _)
  let finv : Empty → WType' β 0 := by
    intro x
    cases x
  have : ∀ x, finv (f x) = x := fun ⟨x, h⟩ => False.elim <| not_lt_of_ge h (WType.depth_pos _)
  Encodable.ofLeftInverse f finv this
#align W_type.encodable_zero W_type.encodable_zero

private def f (n : ℕ) : WType' β (n + 1) → Σa : α, β a → WType' β n
  | ⟨t, h⟩ => by
    cases' t with a f
    have h₀ : ∀ i : β a, WType.depth (f i) ≤ n := fun i =>
      Nat.le_of_lt_succ (lt_of_lt_of_le (WType.depth_lt_depth_mk a f i) h)
    exact ⟨a, fun i : β a => ⟨f i, h₀ i⟩⟩
#align W_type.f W_type.f

private def finv (n : ℕ) : (Σa : α, β a → WType' β n) → WType' β (n + 1)
  | ⟨a, f⟩ =>
    let f' := fun i : β a => (f i).val
    have : WType.depth ⟨a, f'⟩ ≤ n + 1 := add_le_add_right (Finset.sup_le fun b h => (f b).2) 1
    ⟨⟨a, f'⟩, this⟩
#align W_type.finv W_type.finv

variable [Encodable α]

private def encodable_succ (n : Nat) (h : Encodable (WType' β n)) : Encodable (WType' β (n + 1)) :=
  Encodable.ofLeftInverse (f n) (finv n)
    (by
      rintro ⟨⟨_, _⟩, _⟩
      rfl)
#align W_type.encodable_succ W_type.encodable_succ

/-- `W_type` is encodable when `α` is an encodable fintype and for every `a : α`, `β a` is
encodable. -/
instance : Encodable (WType β) :=
  by
  haveI h' : ∀ n, Encodable (W_type' β n) := fun n => Nat.recOn n encodable_zero encodable_succ
  let f : WType β → Σn, W_type' β n := fun t => ⟨t.depth, ⟨t, le_rfl⟩⟩
  let finv : (Σn, W_type' β n) → WType β := fun p => p.2.1
  have : ∀ t, finv (f t) = t := fun t => rfl
  exact Encodable.ofLeftInverse f finv this

end WType


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.calculus.deriv
import analysis.calculus.cont_diff

/-!
# One-dimensional iterated derivatives

We define the `n`-th derivative of a function `f : 𝕜 → F` as a function
`iterated_deriv n f : 𝕜 → F`, as well as a version on domains `iterated_deriv_within n f s : 𝕜 → F`,
and prove their basic properties.

## Main definitions and results

Let `𝕜` be a nondiscrete normed field, and `F` a normed vector space over `𝕜`. Let `f : 𝕜 → F`.

* `iterated_deriv n f` is the `n`-th derivative of `f`, seen as a function from `𝕜` to `F`.
  It is defined as the `n`-th Fréchet derivative (which is a multilinear map) applied to the
  vector `(1, ..., 1)`, to take advantage of all the existing framework, but we show that it
  coincides with the naive iterative definition.
* `iterated_deriv_eq_iterate` states that the `n`-th derivative of `f` is obtained by starting
  from `f` and differentiating it `n` times.
* `iterated_deriv_within n f s` is the `n`-th derivative of `f` within the domain `s`. It only
  behaves well when `s` has the unique derivative property.
* `iterated_deriv_within_eq_iterate` states that the `n`-th derivative of `f` in the domain `s` is
  obtained by starting from `f` and differentiating it `n` times within `s`. This only holds when
  `s` has the unique derivative property.

## Implementation details

The results are deduced from the corresponding results for the more general (multilinear) iterated
Fréchet derivative. For this, we write `iterated_deriv n f` as the composition of
`iterated_fderiv 𝕜 n f` and a continuous linear equiv. As continuous linear equivs respect
differentiability and commute with differentiation, this makes it possible to prove readily that
the derivative of the `n`-th derivative is the `n+1`-th derivative in `iterated_deriv_within_succ`,
by translating the corresponding result `iterated_fderiv_within_succ_apply_left` for the
iterated Fréchet derivative.
-/

noncomputable theory
open_locale classical topological_space big_operators
open filter asymptotics set

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
variables {F : Type*} [normed_group F] [normed_space 𝕜 F]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]

/-- The `n`-th iterated derivative of a function from `𝕜` to `F`, as a function from `𝕜` to `F`. -/
def iterated_deriv (n : ℕ) (f : 𝕜 → F) (x : 𝕜) : F :=
(iterated_fderiv 𝕜 n f x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1)

/-- The `n`-th iterated derivative of a function from `𝕜` to `F` within a set `s`, as a function
from `𝕜` to `F`. -/
def iterated_deriv_within (n : ℕ) (f : 𝕜 → F) (s : set 𝕜) (x : 𝕜) : F :=
(iterated_fderiv_within 𝕜 n f s x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1)

variables {n : ℕ} {f : 𝕜 → F} {s : set 𝕜} {x : 𝕜}

lemma iterated_deriv_within_univ :
  iterated_deriv_within n f univ = iterated_deriv n f :=
by { ext x, rw [iterated_deriv_within, iterated_deriv, iterated_fderiv_within_univ] }

/-! ### Properties of the iterated derivative within a set -/

lemma iterated_deriv_within_eq_iterated_fderiv_within :
  iterated_deriv_within n f s x
  = (iterated_fderiv_within 𝕜 n f s x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1) := rfl

/-- Write the iterated derivative as the composition of a continuous linear equiv and the iterated
Fréchet derivative -/
lemma iterated_deriv_within_eq_equiv_comp :
  iterated_deriv_within n f s
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F).symm ∘
    (iterated_fderiv_within 𝕜 n f s) :=
by { ext x, refl }

/-- Write the iterated Fréchet derivative as the composition of a continuous linear equiv and the
iterated derivative. -/
lemma iterated_fderiv_within_eq_equiv_comp :
  iterated_fderiv_within 𝕜 n f s
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F) ∘ (iterated_deriv_within n f s) :=
by rw [iterated_deriv_within_eq_equiv_comp, ← function.comp.assoc,
  linear_isometry_equiv.self_comp_symm, function.left_id]

/-- The `n`-th Fréchet derivative applied to a vector `(m 0, ..., m (n-1))` is the derivative
multiplied by the product of the `m i`s. -/
lemma iterated_fderiv_within_apply_eq_iterated_deriv_within_mul_prod {m : (fin n) → 𝕜} :
  (iterated_fderiv_within 𝕜 n f s x : ((fin n) → 𝕜) → F) m
  = (∏ i, m i) • iterated_deriv_within n f s x :=
begin
  rw [iterated_deriv_within_eq_iterated_fderiv_within, ← continuous_multilinear_map.map_smul_univ],
  simp
end

@[simp] lemma iterated_deriv_within_zero :
  iterated_deriv_within 0 f s = f :=
by { ext x, simp [iterated_deriv_within] }

@[simp] lemma iterated_deriv_within_one (hs : unique_diff_on 𝕜 s) {x : 𝕜} (hx : x ∈ s):
  iterated_deriv_within 1 f s x = deriv_within f s x :=
by { simp [iterated_deriv_within, iterated_fderiv_within_one_apply hs hx], refl }

/-- If the first `n` derivatives within a set of a function are continuous, and its first `n-1`
derivatives are differentiable, then the function is `C^n`. This is not an equivalence in general,
but this is an equivalence when the set has unique derivatives, see
`cont_diff_on_iff_continuous_on_differentiable_on_deriv`. -/
lemma cont_diff_on_of_continuous_on_differentiable_on_deriv {n : with_top ℕ}
  (Hcont : ∀ (m : ℕ), (m : with_top ℕ) ≤ n →
    continuous_on (λ x, iterated_deriv_within m f s x) s)
  (Hdiff : ∀ (m : ℕ), (m : with_top ℕ) < n →
    differentiable_on 𝕜 (λ x, iterated_deriv_within m f s x) s) :
  cont_diff_on 𝕜 n f s :=
begin
  apply cont_diff_on_of_continuous_on_differentiable_on,
  { simpa [iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_continuous_on_iff] },
  { simpa [iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_differentiable_on_iff] }
end

/-- To check that a function is `n` times continuously differentiable, it suffices to check that its
first `n` derivatives are differentiable. This is slightly too strong as the condition we
require on the `n`-th derivative is differentiability instead of continuity, but it has the
advantage of avoiding the discussion of continuity in the proof (and for `n = ∞` this is optimal).
-/
lemma cont_diff_on_of_differentiable_on_deriv {n : with_top ℕ}
  (h : ∀(m : ℕ), (m : with_top ℕ) ≤ n → differentiable_on 𝕜 (iterated_deriv_within m f s) s) :
  cont_diff_on 𝕜 n f s :=
begin
  apply cont_diff_on_of_differentiable_on,
  simpa only [iterated_fderiv_within_eq_equiv_comp,
    linear_isometry_equiv.comp_differentiable_on_iff]
end

/-- On a set with unique derivatives, a `C^n` function has derivatives up to `n` which are
continuous. -/
lemma cont_diff_on.continuous_on_iterated_deriv_within {n : with_top ℕ} {m : ℕ}
  (h : cont_diff_on 𝕜 n f s) (hmn : (m : with_top ℕ) ≤ n) (hs : unique_diff_on 𝕜 s) :
  continuous_on (iterated_deriv_within m f s) s :=
by simpa only [iterated_deriv_within_eq_equiv_comp, linear_isometry_equiv.comp_continuous_on_iff]
  using h.continuous_on_iterated_fderiv_within hmn hs

/-- On a set with unique derivatives, a `C^n` function has derivatives less than `n` which are
differentiable. -/
lemma cont_diff_on.differentiable_on_iterated_deriv_within {n : with_top ℕ} {m : ℕ}
  (h : cont_diff_on 𝕜 n f s) (hmn : (m : with_top ℕ) < n) (hs : unique_diff_on 𝕜 s) :
  differentiable_on 𝕜 (iterated_deriv_within m f s) s :=
by simpa only [iterated_deriv_within_eq_equiv_comp,
  linear_isometry_equiv.comp_differentiable_on_iff]
  using h.differentiable_on_iterated_fderiv_within hmn hs

/-- The property of being `C^n`, initially defined in terms of the Fréchet derivative, can be
reformulated in terms of the one-dimensional derivative on sets with unique derivatives. -/
lemma cont_diff_on_iff_continuous_on_differentiable_on_deriv {n : with_top ℕ}
  (hs : unique_diff_on 𝕜 s) :
  cont_diff_on 𝕜 n f s ↔
  (∀m:ℕ, (m : with_top ℕ) ≤ n → continuous_on (iterated_deriv_within m f s) s)
  ∧ (∀m:ℕ, (m : with_top ℕ) < n → differentiable_on 𝕜 (iterated_deriv_within m f s) s) :=
by simp only [cont_diff_on_iff_continuous_on_differentiable_on hs,
  iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_continuous_on_iff,
  linear_isometry_equiv.comp_differentiable_on_iff]

/-- The `n+1`-th iterated derivative within a set with unique derivatives can be obtained by
differentiating the `n`-th iterated derivative. -/
lemma iterated_deriv_within_succ {x : 𝕜} (hxs : unique_diff_within_at 𝕜 s x) :
  iterated_deriv_within (n + 1) f s x = deriv_within (iterated_deriv_within n f s) s x :=
begin
  rw [iterated_deriv_within_eq_iterated_fderiv_within, iterated_fderiv_within_succ_apply_left,
      iterated_fderiv_within_eq_equiv_comp, linear_isometry_equiv.comp_fderiv_within _ hxs,
      deriv_within],
  change ((continuous_multilinear_map.mk_pi_field 𝕜 (fin n)
    ((fderiv_within 𝕜 (iterated_deriv_within n f s) s x : 𝕜 → F) 1)) : (fin n → 𝕜 ) → F)
    (λ (i : fin n), 1)
    = (fderiv_within 𝕜 (iterated_deriv_within n f s) s x : 𝕜 → F) 1,
  simp
end

/-- The `n`-th iterated derivative within a set with unique derivatives can be obtained by
iterating `n` times the differentiation operation. -/
lemma iterated_deriv_within_eq_iterate {x : 𝕜} (hs : unique_diff_on 𝕜 s) (hx : x ∈ s) :
  iterated_deriv_within n f s x = ((λ (g : 𝕜 → F), deriv_within g s)^[n]) f x :=
begin
  induction n with n IH generalizing x,
  { simp },
  { rw [iterated_deriv_within_succ (hs x hx), function.iterate_succ'],
    exact deriv_within_congr (hs x hx) (λ y hy, IH hy) (IH hx) }
end

/-- The `n+1`-th iterated derivative within a set with unique derivatives can be obtained by
taking the `n`-th derivative of the derivative. -/
lemma iterated_deriv_within_succ' {x : 𝕜} (hxs : unique_diff_on 𝕜 s) (hx : x ∈ s) :
  iterated_deriv_within (n + 1) f s x = (iterated_deriv_within n (deriv_within f s) s) x :=
by { rw [iterated_deriv_within_eq_iterate hxs hx, iterated_deriv_within_eq_iterate hxs hx], refl }

/-! ### Properties of the iterated derivative on the whole space -/

lemma iterated_deriv_eq_iterated_fderiv :
  iterated_deriv n f x
  = (iterated_fderiv 𝕜 n f x : ((fin n) → 𝕜) → F) (λ(i : fin n), 1) := rfl

/-- Write the iterated derivative as the composition of a continuous linear equiv and the iterated
Fréchet derivative -/
lemma iterated_deriv_eq_equiv_comp :
  iterated_deriv n f
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F).symm ∘ (iterated_fderiv 𝕜 n f) :=
by { ext x, refl }

/-- Write the iterated Fréchet derivative as the composition of a continuous linear equiv and the
iterated derivative. -/
lemma iterated_fderiv_eq_equiv_comp :
  iterated_fderiv 𝕜 n f
  = (continuous_multilinear_map.pi_field_equiv 𝕜 (fin n) F) ∘ (iterated_deriv n f) :=
by rw [iterated_deriv_eq_equiv_comp, ← function.comp.assoc, linear_isometry_equiv.self_comp_symm,
  function.left_id]

/-- The `n`-th Fréchet derivative applied to a vector `(m 0, ..., m (n-1))` is the derivative
multiplied by the product of the `m i`s. -/
lemma iterated_fderiv_apply_eq_iterated_deriv_mul_prod {m : (fin n) → 𝕜} :
  (iterated_fderiv 𝕜 n f x : ((fin n) → 𝕜) → F) m = (∏ i, m i) • iterated_deriv n f x :=
by { rw [iterated_deriv_eq_iterated_fderiv, ← continuous_multilinear_map.map_smul_univ], simp }

@[simp] lemma iterated_deriv_zero :
  iterated_deriv 0 f = f :=
by { ext x, simp [iterated_deriv] }

@[simp] lemma iterated_deriv_one :
  iterated_deriv 1 f = deriv f :=
by { ext x, simp [iterated_deriv], refl }

/-- The property of being `C^n`, initially defined in terms of the Fréchet derivative, can be
reformulated in terms of the one-dimensional derivative. -/
lemma cont_diff_iff_iterated_deriv {n : with_top ℕ} :
  cont_diff 𝕜 n f ↔
(∀m:ℕ, (m : with_top ℕ) ≤ n → continuous (iterated_deriv m f))
∧ (∀m:ℕ, (m : with_top ℕ) < n → differentiable 𝕜 (iterated_deriv m f)) :=
by simp only [cont_diff_iff_continuous_differentiable, iterated_fderiv_eq_equiv_comp,
  linear_isometry_equiv.comp_continuous_iff, linear_isometry_equiv.comp_differentiable_iff]

/-- To check that a function is `n` times continuously differentiable, it suffices to check that its
first `n` derivatives are differentiable. This is slightly too strong as the condition we
require on the `n`-th derivative is differentiability instead of continuity, but it has the
advantage of avoiding the discussion of continuity in the proof (and for `n = ∞` this is optimal).
-/
lemma cont_diff_of_differentiable_iterated_deriv {n : with_top ℕ}
  (h : ∀(m : ℕ), (m : with_top ℕ) ≤ n → differentiable 𝕜 (iterated_deriv m f)) :
  cont_diff 𝕜 n f :=
cont_diff_iff_iterated_deriv.2
  ⟨λ m hm, (h m hm).continuous, λ m hm, (h m (le_of_lt hm))⟩

lemma cont_diff.continuous_iterated_deriv {n : with_top ℕ} (m : ℕ)
  (h : cont_diff 𝕜 n f) (hmn : (m : with_top ℕ) ≤ n) :
  continuous (iterated_deriv m f) :=
(cont_diff_iff_iterated_deriv.1 h).1 m hmn

lemma cont_diff.differentiable_iterated_deriv {n : with_top ℕ} (m : ℕ)
  (h : cont_diff 𝕜 n f) (hmn : (m : with_top ℕ) < n) :
  differentiable 𝕜 (iterated_deriv m f) :=
(cont_diff_iff_iterated_deriv.1 h).2 m hmn

/-- The `n+1`-th iterated derivative can be obtained by differentiating the `n`-th
iterated derivative. -/
lemma iterated_deriv_succ : iterated_deriv (n + 1) f = deriv (iterated_deriv n f) :=
begin
  ext x,
  rw [← iterated_deriv_within_univ, ← iterated_deriv_within_univ, ← deriv_within_univ],
  exact iterated_deriv_within_succ unique_diff_within_at_univ,
end

/-- The `n`-th iterated derivative can be obtained by iterating `n` times the
differentiation operation. -/
lemma iterated_deriv_eq_iterate : iterated_deriv n f = (deriv^[n]) f :=
begin
  ext x,
  rw [← iterated_deriv_within_univ],
  convert iterated_deriv_within_eq_iterate unique_diff_on_univ (mem_univ x),
  simp [deriv_within_univ]
end

/-- The `n+1`-th iterated derivative can be obtained by taking the `n`-th derivative of the
derivative. -/
lemma iterated_deriv_succ' : iterated_deriv (n + 1) f = iterated_deriv n (deriv f) :=
by { rw [iterated_deriv_eq_iterate, iterated_deriv_eq_iterate], refl }


import «06_lib» rename_var
/-
Cette feuille continue l'étude du chapitre 2 du cours de math 101, en abordant
les suites extraites, les valeurs d'adhérence et les suites de Cauchy.
Il n'y a aucun nouvelle commande Lean à apprendre. Cependant les
exercices sont globalement un peu plus difficiles mathématiquement que dans
la feuille 5. Il est donc inutile de travailler cette feuille si la
feuille 5 n'est pas solidement comprise.

On rappelle des lemmes potentiellement utiles :

abs_inferieur_ssi (x y : ℝ) : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y

ineg_triangle (x y : ℝ) : |x + y| ≤ |x| + |y|

abs_diff (x y : ℝ) : |x - y| = |y - x|

superieur_max_ssi (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q

inferieur_max_gauche p q : p ≤ max p q

inferieur_max_droite p q : q ≤ max p q

On rappelle aussi la définition de « u tend vers l »
def limite_suite (u : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - l| ≤ ε

et le lemme d'unicité de la limite démontré dans la feuille 5 :

unicite_limite : limite_suite u l → limite_suite u l' → l = l'
-/

/-- Une fonction `φ : ℕ → ℕ` est une extraction si elle est
strictement croissante. -/
def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m

-- Dans la suite, φ désignera toujours une fonction de ℕ dans ℕ
variable { φ : ℕ → ℕ}

/-
On pourra utiliser le lemme suivant dont la démonstration est une récurrence
immédiate (mais nous n'avons pas encore vu comment faire des démonstrations
par récurrence avec Lean).
-/

/-- Toute extraction est supérieure à l'identité. -/
lemma extraction_superieur_id : extraction φ → ∀ n, n ≤ φ n :=
begin
  intros hyp n,
  induction n with n hn,
    exact nat.zero_le _,
  exact nat.succ_le_of_lt (by linarith [hyp n (n+1) (by linarith)]),
end

/-- Si `φ` est une extraction alors il existe elle prend des valeurs
 arbitrairement grandes pour des indices arbirtrairement grands. -/
lemma extraction_superieur : extraction φ → ∀ N N', ∃ n ≥ N', φ n ≥ N :=
begin
  sorry
end

/-- Un réel `a` est valeur d'adhérence d'une suite `u` s'il
existe une suite extraite de `u` qui tend vers `a`. -/
def valeur_adherence (u : ℕ → ℝ) (a : ℝ) :=
∃ φ, extraction φ ∧ limite_suite (u ∘ φ) a

-- Dans la suite u désigne une suite de réels, et a et l sont des réels
variables {u : ℕ → ℝ} {a l : ℝ}

/-
Dans l'exercice suivant, on note l'utilisation de l'abréviation
« ∃ n ≥ N, ... » qui signifie « ∃ n, n ≥ N et ...».
Lean lit très bien cette abbréviation mais à tendence à l'afficher
sous la forme « ∃ (n : ℕ) (H : n ≥ N) » qui est un peu perturbante
au début, il faut s'y habituer.
-/

/-- Si `a` est valeur d'adhérence de `u` alors il existe des valeurs
de `u` aussi proche qu'on veut de `a` pour des indices aussi grands qu'on veut. -/
lemma valeur_proche_adherence :
  valeur_adherence u a → ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε :=
begin
  sorry
end

/-- Si `u` tend vers `l` alors toutes ses suites extraites tendent vers `l`. -/
lemma limite_extraction_si_limite (h : limite_suite u l) (hφ : extraction φ) :
limite_suite (u ∘ φ) l :=
begin
  sorry
end

/-- Si une suite `u` qui tend vers `l` alors elle n'a pas d'autre valeur
d'adhérence que `l`. -/
lemma val_adh_lim (hl : limite_suite u l) (ha : valeur_adherence u a) : a = l :=
begin
  sorry
end

/-- Une suite `u` est de Cauchy si ses termes sont aussi proches qu'on
veut pour des indices assez grands. -/
def cauchy (u : ℕ → ℝ) := ∀ ε > 0, ∃ N, ∀ p q, p ≥ N → q ≥ N → |u p - u q| ≤ ε

/-- Si une suite `u` converge alors elle est de Cauchy. -/
lemma cauchy_si_converge : (∃ l, limite_suite u l) → cauchy u :=
begin
  sorry
end

/- Dans l'exercice suivant, on pourra utiliser valeur_proche_adherence
  démontré plus haut et dont on rappelle l'énoncé :

valeur_adherence u a → ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε
-/

/-- Si une suite de Cauchy `u` admet une valeur d'adhérence `l` alors elle
converge vers `l`. -/
example (hu : cauchy u) (hl : valeur_adherence u l) : limite_suite u l :=
begin
  sorry
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Scott Morrison

Case bashing:
* on `x ∈ A`, for `A : finset α` or `A : list α`, or
* on `x : A`, with `[fintype A]`.
-/
import data.fintype
import tactic.norm_num

namespace tactic
open lean.parser
open interactive interactive.types expr
open conv.interactive

/-- Checks that the expression looks like `x ∈ A` for `A : finset α`, `multiset α` or `A : list α`,
    and returns the type α. -/
meta def guard_mem_fin (e : expr) : tactic expr :=
do t ← infer_type e,
   α ← mk_mvar,
   to_expr ``(_ ∈ (_ : finset %%α))   tt ff >>= unify t <|>
   to_expr ``(_ ∈ (_ : multiset %%α)) tt ff >>= unify t <|>
   to_expr ``(_ ∈ (_ : list %%α))     tt ff >>= unify t,
   instantiate_mvars α

meta def expr_list_to_list_expr : Π (e : expr), tactic (list expr)
| `(list.cons %%h %%t) := list.cons h <$> expr_list_to_list_expr t
| `([]) := return []
| _ := failed

meta def fin_cases_at_aux : Π (with_list : list expr) (e : expr) (ty_numeric : bool), tactic unit
| with_list e ty_numeric :=
(do
  result ← cases_core e,
  match result with
  -- We have a goal with an equation `s`, and a second goal with a smaller `e : x ∈ _`.
  | [(_, [s], _), (_, [e], _)] :=
    do let sn := local_pp_name s,
        ng ← num_goals,
        -- tidy up the new value
        tactic.interactive.conv (some sn) none
          (to_rhs >> match with_list.nth 0 with
          | (some h) := conv.interactive.change (to_pexpr h)
          | _ := `[try { conv.interactive.simp ff [] [] }] >> when ty_numeric `[try { conv.interactive.norm_num [] }]
          end),
        s ← get_local sn,
        try `[subst %%s],
        ng' ← num_goals,
        when (ng = ng') (rotate_left 1),
        fin_cases_at_aux with_list.tail e ty_numeric
  -- No cases; we're done.
  | [] := skip
  | _ := failed
  end)

meta def fin_cases_at : Π (with_list : option pexpr) (e : expr), tactic unit
| with_list e :=
do ty ← try_core $ guard_mem_fin e,
    match ty with
    | none := -- Deal with `x : A`, where `[fintype A]` is available:
      (do
        ty ← infer_type e,
        i ← to_expr ``(fintype %%ty) >>= mk_instance <|> fail "Failed to find `fintype` instance.",
        t ← to_expr ``(%%e ∈ @fintype.elems %%ty %%i),
        v ← to_expr ``(@fintype.complete %%ty %%i %%e),
        h ← assertv `h t v,
        fin_cases_at with_list h)
    | (some ty) := -- Deal with `x ∈ A` hypotheses:
      (do
        with_list ← match with_list with
        | (some e) := do e ← to_expr ``(%%e : list %%ty), expr_list_to_list_expr e
        | none := return []
        end,
        ty_numeric ← succeeds (unify ty `(ℕ) <|> unify ty `(ℤ) <|> unify ty `(ℚ)),
        fin_cases_at_aux with_list e ty_numeric)
    end

namespace interactive
private meta def hyp := tk "*" *> return none <|> some <$> ident
local postfix `?`:9001 := optional

/--
`fin_cases h` performs case analysis on a hypothesis of the form
`h : A`, where `[fintype A]` is available, or
`h ∈ A`, where `A : finset X`, `A : multiset X` or `A : list X`.

`fin_cases *` performs case analysis on all suitable hypotheses.

As an example, in
```
example (f : ℕ → Prop) (p : fin 3) (h0 : f 0) (h1 : f 1) (h2 : f 2) : f p.val :=
begin
  fin_cases *; simp,
  all_goals { assumption }
end
```
after `fin_cases p; simp`, there are three goals, `f 0`, `f 1`, and `f 2`.
-/
meta def fin_cases : parse hyp → parse (tk "with" *> texpr)? → tactic unit
| none none := focus1 $
               do ctx ← local_context,
                  ctx.mfirst (fin_cases_at none) <|> fail "No hypothesis of the forms `x ∈ A`, where `A : finset X`, `A : list X`, or `A : multiset X`, or `x : A`, with `[fintype A]`."
| none (some _) := fail "Specify a single hypothesis when using a `with` argument."
| (some n) with_list :=
  do
    h ← get_local n,
    focus1 $ fin_cases_at with_list h

end interactive

end tactic


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Extends theory on products
-/

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

@[simp] theorem prod.forall {p : α × β → Prop} : (∀ x, p x) ↔ (∀ a b, p (a, b)) :=
⟨assume h a b, h (a, b), assume h ⟨a, b⟩, h a b⟩

@[simp] theorem prod.exists {p : α × β → Prop} : (∃ x, p x) ↔ (∃ a b, p (a, b)) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

namespace prod

attribute [simp] prod.map

@[simp] lemma map_fst (f : α → γ) (g : β → δ) : ∀(p : α × β), (map f g p).1 = f (p.1)
| ⟨a, b⟩ := rfl

@[simp] lemma map_snd (f : α → γ) (g : β → δ) : ∀(p : α × β), (map f g p).2 = g (p.2)
| ⟨a, b⟩ := rfl

@[simp] theorem mk.inj_iff {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ (a₁ = a₂ ∧ b₁ = b₂) :=
⟨prod.mk.inj, by cc⟩

lemma ext_iff {p q : α × β} : p = q ↔ p.1 = q.1 ∧ p.2 = q.2 :=
by rw [← @mk.eta _ _ p, ← @mk.eta _ _ q, mk.inj_iff]

lemma ext {α β} {p q : α × β} (h₁ : p.1 = q.1) (h₂ : p.2 = q.2) : p = q :=
ext_iff.2 ⟨h₁, h₂⟩

lemma map_def {f : α → γ} {g : β → δ} : prod.map f g = λ (p : α × β), (f p.1, g p.2) :=
funext (λ p, ext (map_fst f g p) (map_snd f g p))

lemma id_prod : (λ (p : α × α), (p.1, p.2)) = id :=
funext $ λ ⟨a, b⟩, rfl

/-- Swap the factors of a product. `swap (a, b) = (b, a)` -/
def swap : α × β → β × α := λp, (p.2, p.1)

@[simp] lemma swap_swap : ∀ x : α × β, swap (swap x) = x
| ⟨a, b⟩ := rfl

@[simp] lemma fst_swap {p : α × β} : (swap p).1 = p.2 := rfl

@[simp] lemma snd_swap {p : α × β} : (swap p).2 = p.1 := rfl

@[simp] lemma swap_prod_mk {a : α} {b : β} : swap (a, b) = (b, a) := rfl

@[simp] lemma swap_swap_eq : swap ∘ swap = @id (α × β) :=
funext swap_swap

@[simp] lemma swap_left_inverse : function.left_inverse (@swap α β) swap :=
swap_swap

@[simp] lemma swap_right_inverse : function.right_inverse (@swap α β) swap :=
swap_swap

lemma eq_iff_fst_eq_snd_eq : ∀{p q : α × β}, p = q ↔ (p.1 = q.1 ∧ p.2 = q.2)
| ⟨p₁, p₂⟩ ⟨q₁, q₂⟩ := by simp

theorem lex_def (r : α → α → Prop) (s : β → β → Prop)
  {p q : α × β} : prod.lex r s p q ↔ r p.1 q.1 ∨ p.1 = q.1 ∧ s p.2 q.2 :=
⟨λ h, by cases h; simp *,
 λ h, match p, q, h with
 | (a, b), (c, d), or.inl h := lex.left _ _ _ h
 | (a, b), (c, d), or.inr ⟨e, h⟩ :=
   by change a = c at e; subst e; exact lex.right _ _ h
 end⟩

instance lex.decidable [decidable_eq α] [decidable_eq β]
  (r : α → α → Prop) (s : β → β → Prop) [decidable_rel r] [decidable_rel s] :
  decidable_rel (prod.lex r s) :=
λ p q, decidable_of_decidable_of_iff (by apply_instance) (lex_def r s).symm

end prod


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

import ring_theory.witt_vector.basic

/-!
# Teichmüller lifts

This file defines `witt_vector.teichmuller`, a monoid hom `R →* 𝕎 R`, which embeds `r : R` as the
`0`-th component of a Witt vector whose other coefficients are `0`.

## Main declarations

- `witt_vector.teichmuller`: the Teichmuller map.
- `witt_vector.map_teichmuller`: `witt_vector.teichmuller` is a natural transformation.
- `witt_vector.ghost_component_teichmuller`:
  the `n`-th ghost component of `witt_vector.teichmuller p r` is `r ^ p ^ n`.

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]
-/

namespace witt_vector

open mv_polynomial
variables (p : ℕ) {R S : Type*} [hp : fact p.prime] [comm_ring R] [comm_ring S]
local notation `𝕎` := witt_vector p -- type as `\bbW`

/--
The underlying function of the monoid hom `witt_vector.teichmuller`.
The `0`-th coefficient of `teichmuller_fun p r` is `r`, and all others are `0`.
-/
def teichmuller_fun (r : R) : 𝕎 R :=
⟨p, λ n, if n = 0 then r else 0⟩

/-!
## `teichmuller` is a monoid homomorphism

On ghost components, it is clear that `teichmuller_fun` is a monoid homomorphism.
But in general the ghost map is not injective.
We follow the same strategy as for proving that the ring operations on `𝕎 R`
satisfy the ring axioms.

1. We first prove it for rings `R` where `p` is invertible,
   because then the ghost map is in fact an isomorphism.
2. After that, we derive the result for `mv_polynomial R ℤ`,
3. and from that we can prove the result for arbitrary `R`.
-/

include hp

private lemma ghost_component_teichmuller_fun (r : R) (n : ℕ) :
  ghost_component n (teichmuller_fun p r) = r ^ p ^ n :=
begin
  rw [ghost_component_apply, aeval_witt_polynomial, finset.sum_eq_single 0,
      pow_zero, one_mul, tsub_zero],
  { refl },
  { intros i hi h0,
    convert mul_zero _, convert zero_pow _,
    { cases i, { contradiction }, { refl } },
    { exact pow_pos hp.1.pos _ } },
  { rw finset.mem_range, intro h, exact (h (nat.succ_pos n)).elim }
end

private lemma map_teichmuller_fun (f : R →+* S) (r : R) :
  map f (teichmuller_fun p r) = teichmuller_fun p (f r) :=
by { ext n, cases n, { refl }, { exact f.map_zero } }

private lemma teichmuller_mul_aux₁ (x y : mv_polynomial R ℚ) :
  teichmuller_fun p (x * y) = teichmuller_fun p x * teichmuller_fun p y :=
begin
  apply (ghost_map.bijective_of_invertible p (mv_polynomial R ℚ)).1,
  rw ring_hom.map_mul,
  ext1 n,
  simp only [pi.mul_apply, ghost_map_apply, ghost_component_teichmuller_fun, mul_pow],
end

private lemma teichmuller_mul_aux₂ (x y : mv_polynomial R ℤ) :
  teichmuller_fun p (x * y) = teichmuller_fun p x * teichmuller_fun p y :=
begin
  refine map_injective (mv_polynomial.map (int.cast_ring_hom ℚ))
    (mv_polynomial.map_injective _ int.cast_injective) _,
  simp only [teichmuller_mul_aux₁, map_teichmuller_fun, ring_hom.map_mul]
end

/-- The Teichmüller lift of an element of `R` to `𝕎 R`.
The `0`-th coefficient of `teichmuller p r` is `r`, and all others are `0`.
This is a monoid homomorphism. -/
def teichmuller : R →* 𝕎 R :=
{ to_fun := teichmuller_fun p,
  map_one' :=
  begin
    ext ⟨⟩,
    { rw one_coeff_zero, refl },
    { rw one_coeff_eq_of_pos _ _ _ (nat.succ_pos n), refl }
  end,
  map_mul' :=
  begin
    intros x y,
    rcases counit_surjective R x with ⟨x, rfl⟩,
    rcases counit_surjective R y with ⟨y, rfl⟩,
    simp only [← map_teichmuller_fun, ← ring_hom.map_mul, teichmuller_mul_aux₂],
  end }

@[simp] lemma teichmuller_coeff_zero (r : R) :
  (teichmuller p r).coeff 0 = r := rfl

@[simp] lemma teichmuller_coeff_pos (r : R) :
  ∀ (n : ℕ) (hn : 0 < n), (teichmuller p r).coeff n = 0
| (n+1) _ := rfl.

@[simp] lemma teichmuller_zero : teichmuller p (0:R) = 0 :=
by ext ⟨⟩; { rw zero_coeff, refl }

/-- `teichmuller` is a natural transformation. -/
@[simp] lemma map_teichmuller (f : R →+* S) (r : R) :
  map f (teichmuller p r) = teichmuller p (f r) :=
map_teichmuller_fun _ _ _

/-- The `n`-th ghost component of `teichmuller p r` is `r ^ p ^ n`. -/
@[simp] lemma ghost_component_teichmuller (r : R) (n : ℕ) :
  ghost_component n (teichmuller p r) = r ^ p ^ n :=
ghost_component_teichmuller_fun _ _ _

end witt_vector


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

! This file was ported from Lean 3 source module ring_theory.finiteness
! leanprover-community/mathlib commit f5edf4694f7c478cbca7a2451bddbd221fc7f869
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Algebra.RestrictScalars
import Mathlib.Algebra.Algebra.Subalgebra.Basic
import Mathlib.GroupTheory.Finiteness
import Mathlib.RingTheory.Ideal.Operations

/-!
# Finiteness conditions in commutative algebra

In this file we define a notion of finiteness that is common in commutative algebra.

## Main declarations

- `Submodule.Fg`, `Ideal.Fg`
  These express that some object is finitely generated as *submodule* over some base ring.

- `Module.Finite`, `RingHom.Finite`, `AlgHom.Finite`
  all of these express that some object is finitely generated *as module* over some base ring.

## Main results

* `exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul` is Nakayama's lemma, in the following form:
  if N is a finitely generated submodule of an ambient R-module M and I is an ideal of R
  such that N ⊆ IN, then there exists r ∈ 1 + I such that rN = 0.

-/

open Function (Surjective)

open BigOperators

namespace Submodule

variable {R : Type _} {M : Type _} [Semiring R] [AddCommMonoid M] [Module R M]

open Set

/-- A submodule of `M` is finitely generated if it is the span of a finite subset of `M`. -/
def Fg (N : Submodule R M) : Prop :=
  ∃ S : Finset M, Submodule.span R ↑S = N
#align submodule.fg Submodule.Fg

theorem fg_def {N : Submodule R M} : N.Fg ↔ ∃ S : Set M, S.Finite ∧ span R S = N :=
  ⟨fun ⟨t, h⟩ => ⟨_, Finset.finite_toSet t, h⟩,
    by
    rintro ⟨t', h, rfl⟩
    rcases Finite.exists_finset_coe h with ⟨t, rfl⟩
    exact ⟨t, rfl⟩⟩
#align submodule.fg_def Submodule.fg_def

theorem fg_iff_addSubmonoid_fg (P : Submodule ℕ M) : P.Fg ↔ P.toAddSubmonoid.Fg :=
  ⟨fun ⟨S, hS⟩ => ⟨S, by simpa [← span_nat_eq_addSubmonoid_closure] using hS⟩, fun ⟨S, hS⟩ =>
    ⟨S, by simpa [← span_nat_eq_addSubmonoid_closure] using hS⟩⟩
#align submodule.fg_iff_add_submonoid_fg Submodule.fg_iff_addSubmonoid_fg

theorem fg_iff_add_subgroup_fg {G : Type _} [AddCommGroup G] (P : Submodule ℤ G) :
    P.Fg ↔ P.toAddSubgroup.Fg :=
  ⟨fun ⟨S, hS⟩ => ⟨S, by simpa [← span_int_eq_addSubgroup_closure] using hS⟩, fun ⟨S, hS⟩ =>
    ⟨S, by simpa [← span_int_eq_addSubgroup_closure] using hS⟩⟩
#align submodule.fg_iff_add_subgroup_fg Submodule.fg_iff_add_subgroup_fg

theorem fg_iff_exists_fin_generating_family {N : Submodule R M} :
    N.Fg ↔ ∃ (n : ℕ)(s : Fin n → M), span R (range s) = N := by
  rw [fg_def]
  constructor
  · rintro ⟨S, Sfin, hS⟩
    obtain ⟨n, f, rfl⟩ := Sfin.fin_embedding
    exact ⟨n, f, hS⟩
  · rintro ⟨n, s, hs⟩
    refine' ⟨range s, finite_range s, hs⟩
#align submodule.fg_iff_exists_fin_generating_family Submodule.fg_iff_exists_fin_generating_family

/-- **Nakayama's Lemma**. Atiyah-Macdonald 2.5, Eisenbud 4.7, Matsumura 2.2,
[Stacks 00DV](https://stacks.math.columbia.edu/tag/00DV) -/
theorem exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul {R : Type _} [CommRing R] {M : Type _}
    [AddCommGroup M] [Module R M] (I : Ideal R) (N : Submodule R M) (hn : N.Fg) (hin : N ≤ I • N) :
    ∃ r : R, r - 1 ∈ I ∧ ∀ n ∈ N, r • n = (0 : M) := by
  rw [fg_def] at hn
  rcases hn with ⟨s, hfs, hs⟩
  have : ∃ r : R, r - 1 ∈ I ∧ N ≤ (I • span R s).comap (LinearMap.lsmul R M r) ∧ s ⊆ N :=
    by
    refine' ⟨1, _, _, _⟩
    · rw [sub_self]
      exact I.zero_mem
    · rw [hs]
      intro n hn
      rw [mem_comap]
      change (1 : R) • n ∈ I • N
      rw [one_smul]
      exact hin hn
    · rw [← span_le, hs]
  clear hin hs
  revert this
  refine' Set.Finite.dinduction_on _ hfs (fun H => _) @fun i s _ _ ih H => _
  · rcases H with ⟨r, hr1, hrn, _⟩
    refine' ⟨r, hr1, fun n hn => _⟩
    specialize hrn hn
    rwa [mem_comap, span_empty, smul_bot, mem_bot] at hrn
  apply ih
  rcases H with ⟨r, hr1, hrn, hs⟩
  rw [← Set.singleton_union, span_union, smul_sup] at hrn
  rw [Set.insert_subset] at hs
  have : ∃ c : R, c - 1 ∈ I ∧ c • i ∈ I • span R s :=
    by
    specialize hrn hs.1
    rw [mem_comap, mem_sup] at hrn
    rcases hrn with ⟨y, hy, z, hz, hyz⟩
    dsimp at hyz
    rw [mem_smul_span_singleton] at hy
    rcases hy with ⟨c, hci, rfl⟩
    use r - c
    constructor
    · rw [sub_right_comm]
      exact I.sub_mem hr1 hci
    · rw [sub_smul, ← hyz, add_sub_cancel']
      exact hz
  rcases this with ⟨c, hc1, hci⟩
  refine' ⟨c * r, _, _, hs.2⟩
  · simpa only [mul_sub, mul_one, sub_add_sub_cancel] using I.add_mem (I.mul_mem_left c hr1) hc1
  · intro n hn
    specialize hrn hn
    rw [mem_comap, mem_sup] at hrn
    rcases hrn with ⟨y, hy, z, hz, hyz⟩
    dsimp at hyz
    rw [mem_smul_span_singleton] at hy
    rcases hy with ⟨d, _, rfl⟩
    simp only [mem_comap, LinearMap.lsmul_apply]
    rw [mul_smul, ← hyz, smul_add, smul_smul, mul_comm, mul_smul]
    exact add_mem (smul_mem _ _ hci) (smul_mem _ _ hz)
#align submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul Submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul

theorem exists_mem_and_smul_eq_self_of_fg_of_le_smul {R : Type _} [CommRing R] {M : Type _}
    [AddCommGroup M] [Module R M] (I : Ideal R) (N : Submodule R M) (hn : N.Fg) (hin : N ≤ I • N) :
    ∃ r ∈ I, ∀ n ∈ N, r • n = n := by
  obtain ⟨r, hr, hr'⟩ := exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul I N hn hin
  exact ⟨-(r - 1), I.neg_mem hr, fun n hn => by simpa [sub_smul] using hr' n hn⟩
#align submodule.exists_mem_and_smul_eq_self_of_fg_of_le_smul Submodule.exists_mem_and_smul_eq_self_of_fg_of_le_smul

theorem fg_bot : (⊥ : Submodule R M).Fg :=
  ⟨∅, by rw [Finset.coe_empty, span_empty]⟩
#align submodule.fg_bot Submodule.fg_bot

theorem _root_.Subalgebra.fg_bot_toSubmodule {R A : Type _} [CommSemiring R] [Semiring A]
    [Algebra R A] : (⊥ : Subalgebra R A).toSubmodule.Fg :=
  ⟨{1}, by simp [Algebra.toSubmodule_bot]⟩
#align subalgebra.fg_bot_to_submodule Subalgebra.fg_bot_toSubmodule

theorem fg_unit {R A : Type _} [CommSemiring R] [Semiring A] [Algebra R A] (I : (Submodule R A)ˣ) :
    (I : Submodule R A).Fg := by
  have : (1 : A) ∈ (I * ↑I⁻¹ : Submodule R A) :=
    by
    rw [I.mul_inv]
    exact one_le.mp le_rfl
  obtain ⟨T, T', hT, hT', one_mem⟩ := mem_span_mul_finite_of_mem_mul this
  refine' ⟨T, span_eq_of_le _ hT _⟩
  rw [← one_mul I, ← mul_one (span R (T : Set A))]
  conv_rhs => rw [← I.inv_mul, ← mul_assoc]
  refine' mul_le_mul_left (le_trans _ <| mul_le_mul_right <| span_le.mpr hT')
  simp only [Units.val_one, span_mul_span]
  rwa [one_le]
#align submodule.fg_unit Submodule.fg_unit

theorem fg_of_isUnit {R A : Type _} [CommSemiring R] [Semiring A] [Algebra R A] {I : Submodule R A}
    (hI : IsUnit I) : I.Fg :=
  fg_unit hI.unit
#align submodule.fg_of_is_unit Submodule.fg_of_isUnit

theorem fg_span {s : Set M} (hs : s.Finite) : Fg (span R s) :=
  ⟨hs.toFinset, by rw [hs.coe_toFinset]⟩
#align submodule.fg_span Submodule.fg_span

theorem fg_span_singleton (x : M) : Fg (R ∙ x) :=
  fg_span (finite_singleton x)
#align submodule.fg_span_singleton Submodule.fg_span_singleton

theorem Fg.sup {N₁ N₂ : Submodule R M} (hN₁ : N₁.Fg) (hN₂ : N₂.Fg) : (N₁ ⊔ N₂).Fg :=
  let ⟨t₁, ht₁⟩ := fg_def.1 hN₁
  let ⟨t₂, ht₂⟩ := fg_def.1 hN₂
  fg_def.2 ⟨t₁ ∪ t₂, ht₁.1.union ht₂.1, by rw [span_union, ht₁.2, ht₂.2]⟩
#align submodule.fg.sup Submodule.Fg.sup

theorem fg_finset_sup {ι : Type _} (s : Finset ι) (N : ι → Submodule R M) (h : ∀ i ∈ s, (N i).Fg) :
    (s.sup N).Fg :=
  Finset.sup_induction fg_bot (fun _ ha _ hb => ha.sup hb) h
#align submodule.fg_finset_sup Submodule.fg_finset_sup

theorem fg_bsupr {ι : Type _} (s : Finset ι) (N : ι → Submodule R M) (h : ∀ i ∈ s, (N i).Fg) :
    (⨆ i ∈ s, N i).Fg := by simpa only [Finset.sup_eq_supᵢ] using fg_finset_sup s N h
#align submodule.fg_bsupr Submodule.fg_bsupr

theorem fg_supᵢ {ι : Type _} [Finite ι] (N : ι → Submodule R M) (h : ∀ i, (N i).Fg) : (supᵢ N).Fg :=
  by
  cases nonempty_fintype ι
  simpa using fg_bsupr Finset.univ N fun i _ => h i
#align submodule.fg_supr Submodule.fg_supᵢ

variable {P : Type _} [AddCommMonoid P] [Module R P]

variable (f : M →ₗ[R] P)

theorem Fg.map {N : Submodule R M} (hs : N.Fg) : (N.map f).Fg :=
  let ⟨t, ht⟩ := fg_def.1 hs
  fg_def.2 ⟨f '' t, ht.1.image _, by rw [span_image, ht.2]⟩
#align submodule.fg.map Submodule.Fg.map

variable {f}

theorem fg_of_fg_map_injective (f : M →ₗ[R] P) (hf : Function.Injective f) {N : Submodule R M}
    (hfn : (N.map f).Fg) : N.Fg :=
  let ⟨t, ht⟩ := hfn
  ⟨t.preimage f fun x _ y _ h => hf h,
    Submodule.map_injective_of_injective hf <|
      by
      rw [f.map_span, Finset.coe_preimage, Set.image_preimage_eq_inter_range,
        Set.inter_eq_self_of_subset_left, ht]
      rw [← LinearMap.range_coe, ← span_le, ht, ← map_top]
      exact map_mono le_top⟩
#align submodule.fg_of_fg_map_injective Submodule.fg_of_fg_map_injective
/- Porting note: Lean not finding this instance is source of the majority of troubles here.
Perhaps it should get its own name -/
alias LinearMap.instSemilinearMapClassLinearMap ← instSLMC

-- Porting note: With etaExperiment, we don't need the @s in the following statement.
theorem fg_of_fg_map {R M P : Type _} [Ring R] [AddCommGroup M] [Module R M] [AddCommGroup P]
    [Module R P] (f : M →ₗ[R] P)
    (hf : @LinearMap.ker R R M P _ _ _ _ _ _ (RingHom.id _) _ instSLMC f = ⊥) {N : Submodule R M}
    (hfn : (@map R R M P _ _ _ _ _ _ (RingHom.id _) _ _ instSLMC f N).Fg) : N.Fg :=
  fg_of_fg_map_injective f (LinearMap.ker_eq_bot.1 hf) hfn
#align submodule.fg_of_fg_map Submodule.fg_of_fg_map

theorem fg_top (N : Submodule R M) : (⊤ : Submodule R N).Fg ↔ N.Fg :=
  ⟨fun h => N.range_subtype ▸ map_top N.subtype ▸ h.map _, fun h =>
    fg_of_fg_map_injective N.subtype Subtype.val_injective <| by rwa [map_top, range_subtype]⟩
#align submodule.fg_top Submodule.fg_top

theorem fg_of_linearEquiv (e : M ≃ₗ[R] P) (h : (⊤ : Submodule R P).Fg) : (⊤ : Submodule R M).Fg :=
  e.symm.range ▸ map_top (e.symm : P →ₗ[R] M) ▸ h.map _
#align submodule.fg_of_linear_equiv Submodule.fg_of_linearEquiv

theorem Fg.prod {sb : Submodule R M} {sc : Submodule R P} (hsb : sb.Fg) (hsc : sc.Fg) :
    (sb.prod sc).Fg :=
  let ⟨tb, htb⟩ := fg_def.1 hsb
  let ⟨tc, htc⟩ := fg_def.1 hsc
  fg_def.2
    ⟨LinearMap.inl R M P '' tb ∪ LinearMap.inr R M P '' tc, (htb.1.image _).union (htc.1.image _),
      by rw [LinearMap.span_inl_union_inr, htb.2, htc.2]⟩
#align submodule.fg.prod Submodule.Fg.prod

theorem fg_pi {ι : Type _} {M : ι → Type _} [Finite ι] [∀ i, AddCommMonoid (M i)]
    [∀ i, Module R (M i)] {p : ∀ i, Submodule R (M i)} (hsb : ∀ i, (p i).Fg) :
    (Submodule.pi Set.univ p).Fg := by
  classical
    simp_rw [fg_def] at hsb⊢
    choose t htf hts using hsb
    -- Porting note: `refine'` doesn't work here
    refine
      ⟨⋃ i, (LinearMap.single i : _ →ₗ[R] _) '' t i, Set.finite_unionᵢ fun i => (htf i).image _, ?_⟩
    simp_rw [span_unionᵢ, span_image, hts, Submodule.supᵢ_map_single]
#align submodule.fg_pi Submodule.fg_pi

/-- Porting note: helping Lean find the coercion to functions below -/
abbrev asFun [AddCommGroup N] [Module R N] (f : M →ₗ[R] N) : M → N :=
  f

-- set_option synthInstance.etaExperiment true in
/-- If 0 → M' → M → M'' → 0 is exact and M' and M'' are
finitely generated then so is M. -/
theorem fg_of_fg_map_of_fg_inf_ker {R M P : Type _} [Ring R] [AddCommGroup M] [Module R M]
    [AddCommGroup P] [Module R P] (f : M →ₗ[R] P) {s : Submodule R M}
    -- Porting note: Lean having trouble both unifying for SLMC and then synthesizing once unified
    -- With etaExperiment, we don't need the @s in the following statement.
    (hs1 : (@map R R M P _ _ _ _ _ _ (RingHom.id _) _ _ instSLMC f s).Fg)
    (hs2 : (s ⊓ @LinearMap.ker R R M P _ _ _ _ _ _ (RingHom.id _) _ instSLMC f).Fg) : s.Fg := by
  haveI := Classical.decEq R
  haveI := Classical.decEq M
  haveI := Classical.decEq P
  cases' hs1 with t1 ht1
  cases' hs2 with t2 ht2
  -- Porting note: With etaExperiment, we don't need the asFun in the following statement.
  have : ∀ y ∈ t1, ∃ x ∈ s, asFun f x = y := by
    intro y hy
    -- Porting note: With etaExperiment, we don't need the @ in the following statement.
    have : y ∈ @map R R M P _ _ _ _ _ _ (RingHom.id _) _ _ instSLMC f s := by
      rw [← ht1]
      exact subset_span hy
    rcases mem_map.1 this with ⟨x, hx1, hx2⟩
    exact ⟨x, hx1, hx2⟩
  -- Porting note: With etaExperiment, we don't need the asFun in the following statement.
  have : ∃ g : P → M, ∀ y ∈ t1, g y ∈ s ∧ asFun f (g y) = y :=
    by
    choose g hg1 hg2 using this
    exists fun y => if H : y ∈ t1 then g y H else 0
    intro y H
    constructor
    · simp only [dif_pos H]
      apply hg1
    · simp only [dif_pos H]
      apply hg2
  cases' this with g hg
  clear this
  exists t1.image g ∪ t2
  rw [Finset.coe_union, span_union, Finset.coe_image]
  apply le_antisymm
  · refine' sup_le (span_le.2 <| image_subset_iff.2 _) (span_le.2 _)
    · intro y hy
      exact (hg y hy).1
    · intro x hx
      have : x ∈ span R t2 := subset_span hx
      rw [ht2] at this
      exact this.1
  intro x hx
  -- Porting note: With etaExperiment, we don't need the asFun and @ in the following statement.
  have : asFun f x ∈ @map R R M P _ _ _ _ _ _ (RingHom.id _) _ _ instSLMC f s := by
    rw [mem_map]
    exact ⟨x, hx, rfl⟩
  rw [← ht1, ← Set.image_id (t1 : Set P), Finsupp.mem_span_image_iff_total] at this
  rcases this with ⟨l, hl1, hl2⟩
  refine'
    mem_sup.2
      ⟨(Finsupp.total M M R id).toFun ((Finsupp.lmapDomain R R g : (P →₀ R) → M →₀ R) l), _,
        x - Finsupp.total M M R id ((Finsupp.lmapDomain R R g : (P →₀ R) → M →₀ R) l), _,
        add_sub_cancel'_right _ _⟩
  · rw [← Set.image_id (g '' ↑t1), Finsupp.mem_span_image_iff_total]
    refine' ⟨_, _, rfl⟩
    haveI : Inhabited P := ⟨0⟩
    rw [← Finsupp.lmapDomain_supported _ _ g, mem_map]
    refine' ⟨l, hl1, _⟩
    rfl
  rw [ht2, mem_inf]
  constructor
  · apply s.sub_mem hx
    rw [Finsupp.total_apply, Finsupp.lmapDomain_apply, Finsupp.sum_mapDomain_index]
    refine' s.sum_mem _
    · intro y hy
      exact s.smul_mem _ (hg y (hl1 hy)).1
    · exact zero_smul _
    · exact fun _ _ _ => add_smul _ _ _
  · dsimp [asFun] at hl2
    rw [LinearMap.mem_ker, f.map_sub, ← hl2]
    rw [Finsupp.total_apply, Finsupp.total_apply, Finsupp.lmapDomain_apply]
    rw [Finsupp.sum_mapDomain_index, Finsupp.sum, Finsupp.sum, f.map_sum]
    rw [sub_eq_zero]
    refine' Finset.sum_congr rfl fun y hy => _
    unfold id
    dsimp [asFun] at hg
    rw [f.map_smul, (hg y (hl1 hy)).2]
    · exact zero_smul _
    · exact fun _ _ _ => add_smul _ _ _
#align submodule.fg_of_fg_map_of_fg_inf_ker Submodule.fg_of_fg_map_of_fg_inf_ker

theorem fg_induction (R M : Type _) [Semiring R] [AddCommMonoid M] [Module R M]
    (P : Submodule R M → Prop) (h₁ : ∀ x, P (Submodule.span R {x}))
    (h₂ : ∀ M₁ M₂, P M₁ → P M₂ → P (M₁ ⊔ M₂)) (N : Submodule R M) (hN : N.Fg) : P N := by
  classical
    obtain ⟨s, rfl⟩ := hN
    induction s using Finset.induction
    · rw [Finset.coe_empty, Submodule.span_empty, ← Submodule.span_zero_singleton]
      apply h₁
    · rw [Finset.coe_insert, Submodule.span_insert]
      apply h₂ <;> apply_assumption
#align submodule.fg_induction Submodule.fg_induction

/-- The kernel of the composition of two linear maps is finitely generated if both kernels are and
the first morphism is surjective. -/
theorem fg_ker_comp {R M N P : Type _} [Ring R] [AddCommGroup M] [Module R M] [AddCommGroup N]
    [Module R N] [AddCommGroup P] [Module R P] (f : M →ₗ[R] N) (g : N →ₗ[R] P)
    -- Porting note: more help both unifying and finding instSLMC
    -- With etaExperiment, we don't need the @s in the following statement.
    (hf1 : (@LinearMap.ker R R M N _ _ _ _ _ _ (RingHom.id _) _ instSLMC f).Fg)
    (hf2 : (@LinearMap.ker R R N P _ _ _ _ _ _ (RingHom.id _) _ instSLMC g).Fg)
    (hsur : Function.Surjective <| asFun f) :
    (@LinearMap.comp R R R M N P _ _ _ _ _ _ _ _ _
      (RingHom.id _) (RingHom.id _) (RingHom.id _) _ g f).ker.Fg := by
  rw [LinearMap.ker_comp]
  apply fg_of_fg_map_of_fg_inf_ker f
  · rwa [Submodule.map_comap_eq, LinearMap.range_eq_top.2 hsur, top_inf_eq]
  -- Porting note With etaExperiment, we don't need the @s in the following `show`.
  · rwa [inf_of_le_right (show (@LinearMap.ker R R M N _ _ _ _ _ _ (RingHom.id _) _ instSLMC f) ≤
      @comap R R M N _ _ _ _ _ _ (RingHom.id _) _ instSLMC f
      (@LinearMap.ker R R N P _ _ _ _ _ _ (RingHom.id _) _ instSLMC g) from comap_mono bot_le)]
#align submodule.fg_ker_comp Submodule.fg_ker_comp

theorem fg_restrictScalars {R S M : Type _} [CommSemiring R] [Semiring S] [Algebra R S]
    [AddCommGroup M] [Module S M] [Module R M] [IsScalarTower R S M] (N : Submodule S M)
    (hfin : N.Fg) (h : Function.Surjective (algebraMap R S)) : (Submodule.restrictScalars R N).Fg :=
  by
  obtain ⟨X, rfl⟩ := hfin
  use X
  exact (Submodule.restrictScalars_span R S h (X : Set M)).symm
#align submodule.fg_restrict_scalars Submodule.fg_restrictScalars

theorem Fg.stablizes_of_supᵢ_eq {M' : Submodule R M} (hM' : M'.Fg) (N : ℕ →o Submodule R M)
    (H : supᵢ N = M') : ∃ n, M' = N n := by
  obtain ⟨S, hS⟩ := hM'
  have : ∀ s : S, ∃ n, (s : M) ∈ N n := fun s =>
    (Submodule.mem_supᵢ_of_chain N s).mp
      (by
        rw [H, ← hS]
        exact Submodule.subset_span s.2)
  choose f hf using this
  use S.attach.sup f
  apply le_antisymm
  · conv_lhs => rw [← hS]
    rw [Submodule.span_le]
    intro s hs
    exact N.2 (Finset.le_sup <| S.mem_attach ⟨s, hs⟩) (hf _)
  · rw [← H]
    exact le_supᵢ _ _
#align submodule.fg.stablizes_of_supr_eq Submodule.Fg.stablizes_of_supᵢ_eq

/-- Finitely generated submodules are precisely compact elements in the submodule lattice. -/
theorem fg_iff_compact (s : Submodule R M) : s.Fg ↔ CompleteLattice.IsCompactElement s := by
  classical
    -- Introduce shorthand for span of an element
    let sp : M → Submodule R M := fun a => span R {a}
    -- Trivial rewrite lemma; a small hack since simp (only) & rw can't accomplish this smoothly.
    have supr_rw : ∀ t : Finset M, (⨆ x ∈ t, sp x) = ⨆ x ∈ (↑t : Set M), sp x := fun t => by rfl
    constructor
    · rintro ⟨t, rfl⟩
      rw [span_eq_supᵢ_of_singleton_spans, ← supr_rw, ← Finset.sup_eq_supᵢ t sp]
      apply CompleteLattice.finset_sup_compact_of_compact
      exact fun n _ => singleton_span_isCompactElement n
    · intro h
      -- s is the Sup of the spans of its elements.
      have sSup : s = supₛ (sp '' ↑s) := by
        rw [supₛ_eq_supᵢ, supᵢ_image, ← span_eq_supᵢ_of_singleton_spans, eq_comm, span_eq]
      -- by h, s is then below (and equal to) the sup of the spans of finitely many elements.
      obtain ⟨u, ⟨huspan, husup⟩⟩ := h (sp '' ↑s) (le_of_eq sSup)
      have ssup : s = u.sup id := by
        suffices : u.sup id ≤ s
        exact le_antisymm husup this
        rw [sSup, Finset.sup_id_eq_supₛ]
        exact supₛ_le_supₛ huspan
      -- Porting note: had to split this out of the `obtain`
      have := Finset.subset_image_iff.mp huspan
      obtain ⟨t, ⟨-, rfl⟩⟩ := this
      rw [Finset.sup_finset_image, Function.comp.left_id, Finset.sup_eq_supᵢ, supr_rw, ←
        span_eq_supᵢ_of_singleton_spans, eq_comm] at ssup
      exact ⟨t, ssup⟩
#align submodule.fg_iff_compact Submodule.fg_iff_compact

end Submodule

namespace Submodule

section Map₂

variable {R M N P : Type _}

variable [CommSemiring R] [AddCommMonoid M] [AddCommMonoid N] [AddCommMonoid P]

variable [Module R M] [Module R N] [Module R P]

theorem Fg.map₂ (f : M →ₗ[R] N →ₗ[R] P) {p : Submodule R M} {q : Submodule R N} (hp : p.Fg)
    (hq : q.Fg) : (map₂ f p q).Fg :=
  let ⟨sm, hfm, hm⟩ := fg_def.1 hp
  let ⟨sn, hfn, hn⟩ := fg_def.1 hq
  fg_def.2
    ⟨Set.image2 (fun m n => f m n) sm sn, hfm.image2 _ hfn,
      map₂_span_span R f sm sn ▸ hm ▸ hn ▸ rfl⟩
#align submodule.fg.map₂ Submodule.Fg.map₂

end Map₂

section Mul

variable {R : Type _} {A : Type _} [CommSemiring R] [Semiring A] [Algebra R A]

variable {M N : Submodule R A}

theorem Fg.mul (hm : M.Fg) (hn : N.Fg) : (M * N).Fg :=
  hm.map₂ _ hn
#align submodule.fg.mul Submodule.Fg.mul

theorem Fg.pow (h : M.Fg) (n : ℕ) : (M ^ n).Fg :=
  Nat.recOn n ⟨{1}, by simp [one_eq_span]⟩ fun n ih => by simpa [pow_succ] using h.mul ih
#align submodule.fg.pow Submodule.Fg.pow

end Mul

end Submodule

namespace Ideal

variable {R : Type _} {M : Type _} [Semiring R] [AddCommMonoid M] [Module R M]

/-- An ideal of `R` is finitely generated if it is the span of a finite subset of `R`.

This is defeq to `submodule.fg`, but unfolds more nicely. -/
def Fg (I : Ideal R) : Prop :=
  ∃ S : Finset R, Ideal.span ↑S = I
#align ideal.fg Ideal.Fg

/-- The image of a finitely generated ideal is finitely generated.

This is the `ideal` version of `submodule.fg.map`. -/
theorem Fg.map {R S : Type _} [Semiring R] [Semiring S] {I : Ideal R} (h : I.Fg) (f : R →+* S) :
    (I.map f).Fg := by
  classical
    obtain ⟨s, hs⟩ := h
    refine' ⟨s.image f, _⟩
    rw [Finset.coe_image, ← Ideal.map_span, hs]
#align ideal.fg.map Ideal.Fg.map

set_option synthInstance.etaExperiment true in
theorem fg_ker_comp {R S A : Type _} [CommRing R] [CommRing S] [CommRing A] (f : R →+* S)
    (g : S →+* A) (hf : f.ker.Fg) (hg : g.ker.Fg) (hsur : Function.Surjective f) :
    (g.comp f).ker.Fg := by
  letI : Algebra R S := RingHom.toAlgebra f
  letI : Algebra R A := RingHom.toAlgebra (g.comp f)
  letI : Algebra S A := RingHom.toAlgebra g
  letI : IsScalarTower R S A := IsScalarTower.of_algebraMap_eq fun _ => rfl
  let f₁ := Algebra.linearMap R S
  let g₁ := (IsScalarTower.toAlgHom R S A).toLinearMap
  exact Submodule.fg_ker_comp f₁ g₁ hf (Submodule.fg_restrictScalars (RingHom.ker g) hg hsur) hsur
#align ideal.fg_ker_comp Ideal.fg_ker_comp

theorem exists_radical_pow_le_of_fg {R : Type _} [CommSemiring R] (I : Ideal R) (h : I.radical.Fg) :
    ∃ n : ℕ, I.radical ^ n ≤ I := by
  have := le_refl I.radical; revert this
  refine' Submodule.fg_induction _ _ (fun J => J ≤ I.radical → ∃ n : ℕ, J ^ n ≤ I) _ _ _ h
  · intro x hx
    obtain ⟨n, hn⟩ := hx (subset_span (Set.mem_singleton x))
    exact ⟨n, by rwa [← Ideal.span, span_singleton_pow, span_le, Set.singleton_subset_iff]⟩
  · intro J K hJ hK hJK
    obtain ⟨n, hn⟩ := hJ fun x hx => hJK <| Ideal.mem_sup_left hx
    obtain ⟨m, hm⟩ := hK fun x hx => hJK <| Ideal.mem_sup_right hx
    use n + m
    rw [← Ideal.add_eq_sup, add_pow, Ideal.sum_eq_sup, Finset.sup_le_iff]
    refine' fun i _ => Ideal.mul_le_right.trans _
    obtain h | h := le_or_lt n i
    · apply Ideal.mul_le_right.trans ((Ideal.pow_le_pow h).trans hn)
    · apply Ideal.mul_le_left.trans
      refine' (Ideal.pow_le_pow _).trans hm
      rw [add_comm, Nat.add_sub_assoc h.le]
      apply Nat.le_add_right
#align ideal.exists_radical_pow_le_of_fg Ideal.exists_radical_pow_le_of_fg

end Ideal

section ModuleAndAlgebra

variable (R A B M N : Type _)

/-- A module over a semiring is `finite` if it is finitely generated as a module. -/
class Module.Finite [Semiring R] [AddCommMonoid M] [Module R M] : Prop where
  out : (⊤ : Submodule R M).Fg
#align module.finite Module.Finite

attribute [inherit_doc Module.Finite] Module.Finite.out

namespace Module

variable [Semiring R] [AddCommMonoid M] [Module R M] [AddCommMonoid N] [Module R N]

theorem finite_def {R M} [Semiring R] [AddCommMonoid M] [Module R M] :
    Finite R M ↔ (⊤ : Submodule R M).Fg :=
  ⟨fun h => h.1, fun h => ⟨h⟩⟩
#align module.finite_def Module.finite_def

namespace Finite

open Submodule Set

theorem iff_addMonoid_fg {M : Type _} [AddCommMonoid M] : Module.Finite ℕ M ↔ AddMonoid.Fg M :=
  ⟨fun h => AddMonoid.fg_def.2 <| (Submodule.fg_iff_addSubmonoid_fg ⊤).1 (finite_def.1 h), fun h =>
    finite_def.2 <| (Submodule.fg_iff_addSubmonoid_fg ⊤).2 (AddMonoid.fg_def.1 h)⟩
#align module.finite.iff_add_monoid_fg Module.Finite.iff_addMonoid_fg

theorem iff_addGroup_fg {G : Type _} [AddCommGroup G] : Module.Finite ℤ G ↔ AddGroup.Fg G :=
  ⟨fun h => AddGroup.fg_def.2 <| (Submodule.fg_iff_add_subgroup_fg ⊤).1 (finite_def.1 h), fun h =>
    finite_def.2 <| (Submodule.fg_iff_add_subgroup_fg ⊤).2 (AddGroup.fg_def.1 h)⟩
#align module.finite.iff_add_group_fg Module.Finite.iff_addGroup_fg

variable {R M N}

theorem exists_fin [Finite R M] : ∃ (n : ℕ)(s : Fin n → M), Submodule.span R (range s) = ⊤ :=
  Submodule.fg_iff_exists_fin_generating_family.mp out
#align module.finite.exists_fin Module.Finite.exists_fin

theorem of_surjective [hM : Finite R M] (f : M →ₗ[R] N) (hf : Surjective f) : Finite R N :=
  ⟨by
    rw [← LinearMap.range_eq_top.2 hf, ← Submodule.map_top]
    exact hM.1.map f⟩
#align module.finite.of_surjective Module.Finite.of_surjective

variable (R)

instance self : Finite R R :=
  ⟨⟨{1}, by simpa only [Finset.coe_singleton] using Ideal.span_singleton_one⟩⟩
#align module.finite.self Module.Finite.self

variable (M)

theorem of_restrictScalars_finite (R A M : Type _) [CommSemiring R] [Semiring A] [AddCommMonoid M]
    [Module R M] [Module A M] [Algebra R A] [IsScalarTower R A M] [hM : Finite R M] : Finite A M :=
  by
  rw [finite_def, Submodule.fg_def] at hM⊢
  obtain ⟨S, hSfin, hSgen⟩ := hM
  refine' ⟨S, hSfin, eq_top_iff.2 _⟩
  have := Submodule.span_le_restrictScalars R A S
  rw [hSgen] at this
  exact this
#align module.finite.of_restrict_scalars_finite Module.Finite.of_restrictScalars_finite

variable {R M}

instance prod [hM : Finite R M] [hN : Finite R N] : Finite R (M × N) :=
  ⟨by
    rw [← Submodule.prod_top]
    exact hM.1.prod hN.1⟩
#align module.finite.prod Module.Finite.prod

instance pi {ι : Type _} {M : ι → Type _} [_root_.Finite ι] [∀ i, AddCommMonoid (M i)]
    [∀ i, Module R (M i)] [h : ∀ i, Finite R (M i)] : Finite R (∀ i, M i) :=
  ⟨by
    rw [← Submodule.pi_top]
    exact Submodule.fg_pi fun i => (h i).1⟩
#align module.finite.pi Module.Finite.pi

theorem equiv [Finite R M] (e : M ≃ₗ[R] N) : Finite R N :=
  of_surjective (e : M →ₗ[R] N) e.surjective
#align module.finite.equiv Module.Finite.equiv

section Algebra

theorem trans {R : Type _} (A B : Type _) [CommSemiring R] [CommSemiring A] [Algebra R A]
    [Semiring B] [Algebra R B] [Algebra A B] [IsScalarTower R A B] :
    ∀ [Finite R A] [Finite A B], Finite R B
  | ⟨⟨s, hs⟩⟩, ⟨⟨t, ht⟩⟩ =>
    ⟨Submodule.fg_def.2
        ⟨Set.image2 (· • ·) (↑s : Set A) (↑t : Set B),
          Set.Finite.image2 _ s.finite_toSet t.finite_toSet, by
          erw [Set.image2_smul, Submodule.span_smul_of_span_eq_top hs (↑t : Set B), ht,
            Submodule.restrictScalars_top]⟩⟩
#align module.finite.trans Module.Finite.trans

end Algebra

end Finite

end Module

/-- Porting note: reminding Lean about this instance for Module.Finite.base_change -/
local instance [CommSemiring R] [Semiring A] [Algebra R A] [AddCommMonoid M] [Module R M] :
  Module A (TensorProduct R A M) :=
  haveI : SMulCommClass R A A := IsScalarTower.to_smulCommClass
  TensorProduct.leftModule

instance Module.Finite.base_change [CommSemiring R] [Semiring A] [Algebra R A] [AddCommMonoid M]
    [Module R M] [h : Module.Finite R M] : Module.Finite A (TensorProduct R A M) := by
  classical
    obtain ⟨s, hs⟩ := h.out
    refine' ⟨⟨s.image (TensorProduct.mk R A M 1), eq_top_iff.mpr fun x _ => _⟩⟩
    apply @TensorProduct.induction_on _ _ _ _ _ _ _ _ _ x
    · exact zero_mem _
    · intro x y
      -- Porting note: new TC reminder
      haveI : IsScalarTower R A (TensorProduct R A M) := TensorProduct.isScalarTower_left
      rw [Finset.coe_image, ← Submodule.span_span_of_tower R, Submodule.span_image, hs,
        Submodule.map_top, LinearMap.range_coe]
      change _ ∈ Submodule.span A (Set.range <| TensorProduct.mk R A M 1)
      rw [← mul_one x, ← smul_eq_mul, ← TensorProduct.smul_tmul']
      exact Submodule.smul_mem _ x (Submodule.subset_span <| Set.mem_range_self y)
    · exact fun _ _ => Submodule.add_mem _
#align module.finite.base_change Module.Finite.base_change

instance Module.Finite.tensorProduct [CommSemiring R] [AddCommMonoid M] [Module R M]
    [AddCommMonoid N] [Module R N] [hM : Module.Finite R M] [hN : Module.Finite R N] :
    Module.Finite R (TensorProduct R M N) where
  out := (TensorProduct.map₂_mk_top_top_eq_top R M N).subst (hM.out.map₂ _ hN.out)
#align module.finite.tensor_product Module.Finite.tensorProduct

end ModuleAndAlgebra

namespace RingHom

variable {A B C : Type _} [CommRing A] [CommRing B] [CommRing C]

/-- A ring morphism `A →+* B` is `finite` if `B` is finitely generated as `A`-module. -/
def Finite (f : A →+* B) : Prop :=
  letI : Algebra A B := f.toAlgebra
  Module.Finite A B
#align ring_hom.finite RingHom.Finite

namespace Finite

variable (A)

theorem id : Finite (RingHom.id A) :=
  Module.Finite.self A
#align ring_hom.finite.id RingHom.Finite.id

variable {A}

theorem of_surjective (f : A →+* B) (hf : Surjective f) : f.Finite :=
  letI := f.toAlgebra
  Module.Finite.of_surjective (Algebra.ofId A B).toLinearMap hf
#align ring_hom.finite.of_surjective RingHom.Finite.of_surjective

theorem of_comp_finite {f : A →+* B} {g : B →+* C} (h : (g.comp f).Finite) : g.Finite := by
  letI := f.toAlgebra
  letI := g.toAlgebra
  letI := (g.comp f).toAlgebra
  letI : IsScalarTower A B C := RestrictScalars.isScalarTower A B C
  letI : Module.Finite A C := h
  exact Module.Finite.of_restrictScalars_finite A B C
#align ring_hom.finite.of_comp_finite RingHom.Finite.of_comp_finite

end Finite

end RingHom

namespace AlgHom

variable {R A B C : Type _} [CommRing R]

variable [CommRing A] [CommRing B] [CommRing C]

variable [Algebra R A] [Algebra R B] [Algebra R C]

/-- An algebra morphism `A →ₐ[R] B` is finite if it is finite as ring morphism.
In other words, if `B` is finitely generated as `A`-module. -/
def Finite (f : A →ₐ[R] B) : Prop :=
  f.toRingHom.Finite
#align alg_hom.finite AlgHom.Finite

namespace Finite

variable (R A)

theorem id : Finite (AlgHom.id R A) :=
  RingHom.Finite.id A
#align alg_hom.finite.id AlgHom.Finite.id

variable {R A}

theorem comp {g : B →ₐ[R] C} {f : A →ₐ[R] B} (hg : g.Finite) (hf : f.Finite) : (g.comp f).Finite :=
  RingHom.Finite.comp hg hf
#align alg_hom.finite.comp AlgHom.Finite.comp

theorem of_surjective (f : A →ₐ[R] B) (hf : Surjective f) : f.Finite :=
  RingHom.Finite.of_surjective f.toRingHom hf
#align alg_hom.finite.of_surjective AlgHom.Finite.of_surjective

theorem of_comp_finite {f : A →ₐ[R] B} {g : B →ₐ[R] C} (h : (g.comp f).Finite) : g.Finite :=
  RingHom.Finite.of_comp_finite h
#align alg_hom.finite.of_comp_finite AlgHom.Finite.of_comp_finite

end Finite

end AlgHom


/- -----------------------------------------------------------------------
Finite types.
----------------------------------------------------------------------- -/

import .c1_fin

namespace qp
namespace stdaux

universe variable ℓ

/-! #brief A finite sort.
-/
class FinSort (A : Sort ℓ)
    : Sort (max 1 ℓ)
:= (card : ℕ)
   (to_n : A → fin card)
   (of_n : fin card → A)
   (of_n_to : function.left_inverse of_n to_n)
   (to_n_of : function.left_inverse to_n of_n)

-- /-! #brief Cardinality is non-evil.
-- -/
-- theorem FinSort.card_nonevil {A : Sort ℓ}
--     (A_FinType₁ A_FinType₂ : FinSort A)
--     : @FinSort.card A A_FinType₁ = @FinSort.card A A_FinType₂
-- := sorry

/-! #brief Finite sorts have decidable equality.
-/
instance FinSort.decidable_eq (A : Sort ℓ)
    [A_FinSort : FinSort A]
    : decidable_eq A
:= λ a₁ a₂, if ω : FinSort.to_n a₁ = FinSort.to_n a₂
            then decidable.is_true (function.injective_of_left_inverse (FinSort.of_n_to A) ω)
            else decidable.is_false (λ ω', ω (congr_arg FinSort.to_n ω'))

/-! #brief punit is a finite sort.
-/
instance punit.FinSort
    : FinSort punit.{ℓ}
:= { card := 1
   , to_n := λ u, fin.zero
   , of_n := λ n, punit.star
   , of_n_to := λ u, begin cases u, trivial end
   , to_n_of := λ n, eq.symm (fin.zero_uniq n)
   }

/-! #brief The empty sort.
-/
inductive pempty : Sort.{ℓ}

/-! #brief punit is a finite sort.
-/
instance pempty.FinSort
    : FinSort pempty.{ℓ}
:= { card := 0
   , to_n := λ u, by cases u
   , of_n := fin.zero_elim
   , of_n_to := λ u, begin cases u end
   , to_n_of := λ n, fin.zero_elim n
   }

/-! #brief Every true proposition is a finite sort.
-/
instance Prop.true_FinSort
    (P : Prop)
    (ωP : P)
    : FinSort P
:= { card := 1
   , to_n := λ ω, fin.zero
   , of_n := λ n, ωP
   , of_n_to := λ ω, begin apply proof_irrel end
   , to_n_of := λ n, begin rw fin.zero_uniq n end
   }

/-! #brief Every false proposition is a finite sort.
-/
instance Prop.false_FinSort
    (P : Prop)
    (ωP : ¬ P)
    : FinSort P
:= { card := 0
   , to_n := λ ω, begin apply false.rec, exact ωP ω end
   , of_n := λ n, fin.zero_elim n
   , of_n_to := λ ω, begin apply proof_irrel end
   , to_n_of := λ n, fin.zero_elim n
   }

/-! #brief Every decidable proposition is a finite sort.
-/
instance Prop.decidable_FinSort
    (P : Prop)
    [P_decidable : decidable P]
    : FinSort P
:= if ω : P
    then Prop.true_FinSort P ω
    else Prop.false_FinSort P ω

/-! #brief A finite type.
-/
@[class] definition FinType (A : Type ℓ)
    : Type ℓ
:= FinSort A

definition FinType.card (A : Type ℓ)
    [A_FinType : FinType A]
:= @FinSort.card A A_FinType

definition FinType.to_n {A : Type ℓ}
    [A_FinType : FinType A]
    : A → fin (FinType.card A)
:= @FinSort.to_n A A_FinType

definition FinType.of_n {A : Type ℓ}
    [A_FinType : FinType A]
    : fin (FinType.card A) → A
:= @FinSort.of_n A A_FinType

definition FinType.of_n_to {A : Type ℓ}
    [A_FinType : FinType A]
    : function.left_inverse
        (@FinType.of_n A A_FinType)
        (@FinType.to_n A A_FinType)
:= @FinSort.of_n_to A A_FinType

definition FinType.to_n_of {A : Type ℓ}
    [A_FinType : FinType A]
    : function.left_inverse
        (@FinType.to_n A A_FinType)
        (@FinType.of_n A A_FinType)
:= @FinSort.to_n_of A A_FinType

definition FinType.enum (A : Type ℓ)
    [A_FinType : FinType A]
    : list A
:= fin.enum (@FinType.of_n A A_FinType)

/-! #brief A proposition for when a type is empty.
-/
definition IsEmptyType (A : Type ℓ)
    : Prop
:= A → false

/-! #brief A handy eliminator for empty types.
-/
definition {ℓ₂} IsEmptyType.empty_elim {A : Type ℓ}
    (A_IsEmpty : IsEmptyType A)
    {B : Sort ℓ₂}
    (a : A)
    : B
:= false.rec B (A_IsEmpty a)

/-! #brief Finite types have decidable IsTypeEmpty.
-/
instance FinType.decidable.IsEmptyType (A : Type ℓ)
    [A_FinType : FinType A]
    : decidable (IsEmptyType A)
:= if ωcard : 0 = FinType.card A
    then decidable.is_true
          (λ a, fin.zero_elim (cast (by rw ωcard) (FinType.to_n a)))
    else decidable.is_false
          (λ ω, ω (FinType.of_n (fin.intro_zero ωcard)))

/-! #brief Finite types have decidable equality.
-/
instance FinType.decidable_eq (A : Type ℓ)
    [A_FinType : FinType A]
    : decidable_eq A
:= @FinSort.decidable_eq A A_FinType

/-! #brief fin n is a finite type for all N.
-/
instance fin.FinType (N : ℕ)
    : FinType (fin N)
:= { card := N
   , to_n := λ n, n
   , of_n := λ n, n
   , of_n_to := eq.refl
   , to_n_of := eq.refl
   }

end stdaux
end qp


/-
Copyright (c) 2019 Patrick MAssot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.absolute_value
import Mathlib.topology.instances.real
import Mathlib.topology.uniform_space.completion
import Mathlib.PostPort

namespace Mathlib

/-!
# Comparison of Cauchy reals and Bourbaki reals

In `data.real.basic` real numbers are defined using the so called Cauchy construction (although
it is due to Georg Cantor). More precisely, this construction applies to commutative rings equipped
with an absolute value with values in a linear ordered field.

On the other hand, in the `uniform_space` folder, we construct completions of general uniform
spaces, which allows to construct the Bourbaki real numbers. In this file we build uniformly
continuous bijections from Cauchy reals to Bourbaki reals and back. This is a cross sanity check of
both constructions. Of course those two constructions are variations on the completion idea, simply
with different level of generality. Comparing with Dedekind cuts or quasi-morphisms would be of a
completely different nature.

Note that `metric_space/cau_seq_filter` also relates the notions of Cauchy sequences in metric
spaces and Cauchy filters in general uniform spaces, and `metric_space/completion` makes sure
the completion (as a uniform space) of a metric space is a metric space.

Historical note: mathlib used to define real numbers in an intermediate way, using completion
of uniform spaces but extending multiplication in an ad-hoc way.

TODO:
* Upgrade this isomorphism to a topological ring isomorphism.
* Do the same comparison for p-adic numbers

## Implementation notes

The heavy work is done in `topology/uniform_space/abstract_completion` which provides an abstract
caracterization of completions of uniform spaces, and isomorphisms between them. The only work left
here is to prove the uniform space structure coming from the absolute value on ℚ (with values in ℚ,
not referring to ℝ) coincides with the one coming from the metric space structure (which of course
does use ℝ).

## References

* [N. Bourbaki, *Topologie générale*][bourbaki1966]

## Tags

real numbers, completion, uniform spaces
-/

/-- The metric space uniform structure on ℚ (which presupposes the existence
of real numbers) agrees with the one coming directly from (abs : ℚ → ℚ). -/
theorem rat.uniform_space_eq :
    is_absolute_value.uniform_space abs = metric_space.to_uniform_space' :=
  sorry

/-- Cauchy reals packaged as a completion of ℚ using the absolute value route. -/
def rational_cau_seq_pkg : abstract_completion ℚ :=
  abstract_completion.mk ℝ coe metric_space.to_uniform_space' real.complete_space
    metric_space.to_separated sorry sorry

namespace compare_reals

/-- Type wrapper around ℚ to make sure the absolute value uniform space instance is picked up
instead of the metric space one. We proved in rat.uniform_space_eq that they are equal,
but they are not definitionaly equal, so it would confuse the type class system (and probably
also human readers). -/
def Q := ℚ

protected instance Q.uniform_space : uniform_space Q := is_absolute_value.uniform_space abs

/-- Real numbers constructed as in Bourbaki. -/
def Bourbakiℝ := uniform_space.completion Q

protected instance bourbaki.uniform_space : uniform_space Bourbakiℝ :=
  uniform_space.completion.uniform_space Q

/-- Bourbaki reals packaged as a completion of Q using the general theory. -/
def Bourbaki_pkg : abstract_completion Q := uniform_space.completion.cpkg

/-- The equivalence between Bourbaki and Cauchy reals-/
def compare_equiv : Bourbakiℝ ≃ ℝ :=
  abstract_completion.compare_equiv Bourbaki_pkg rational_cau_seq_pkg

theorem compare_uc : uniform_continuous ⇑compare_equiv :=
  abstract_completion.uniform_continuous_compare_equiv Bourbaki_pkg rational_cau_seq_pkg

theorem compare_uc_symm : uniform_continuous ⇑(equiv.symm compare_equiv) :=
  abstract_completion.uniform_continuous_compare_equiv_symm Bourbaki_pkg rational_cau_seq_pkg

end Mathlib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.finset.lattice
import Mathlib.data.multiset.sort
import Mathlib.data.list.nodup_equiv_fin
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Construct a sorted list from a finset.
-/

namespace finset

/-! ### sort -/

/-- `sort s` constructs a sorted list from the unordered set `s`.
  (Uses merge sort algorithm.) -/
def sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] (s : finset α) : List α :=
  multiset.sort r (val s)

@[simp] theorem sort_sorted {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] (s : finset α) : list.sorted r (sort r s) :=
  multiset.sort_sorted r (val s)

@[simp] theorem sort_eq {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] (s : finset α) : ↑(sort r s) = val s :=
  multiset.sort_eq r (val s)

@[simp] theorem sort_nodup {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] (s : finset α) : list.nodup (sort r s) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (multiset.nodup ↑(sort r s))) (sort_eq r s))) (nodup s)

@[simp] theorem sort_to_finset {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] [DecidableEq α] (s : finset α) : list.to_finset (sort r s) = s :=
  list.to_finset_eq (sort_nodup r s) ▸ eq_of_veq (sort_eq r s)

@[simp] theorem mem_sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] {s : finset α} {a : α} : a ∈ sort r s ↔ a ∈ s :=
  multiset.mem_sort r

@[simp] theorem length_sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r] [is_total α r] {s : finset α} : list.length (sort r s) = card s :=
  multiset.length_sort r

theorem sort_sorted_lt {α : Type u_1} [linear_order α] (s : finset α) : list.sorted Less (sort LessEq s) :=
  list.pairwise.imp₂ lt_of_le_of_ne (sort_sorted LessEq s) (sort_nodup LessEq s)

theorem sorted_zero_eq_min'_aux {α : Type u_1} [linear_order α] (s : finset α) (h : 0 < list.length (sort LessEq s)) (H : finset.nonempty s) : list.nth_le (sort LessEq s) 0 h = min' s H := sorry

theorem sorted_zero_eq_min' {α : Type u_1} [linear_order α] {s : finset α} {h : 0 < list.length (sort LessEq s)} : list.nth_le (sort LessEq s) 0 h =
  min' s (iff.mp card_pos (eq.mp (Eq._oldrec (Eq.refl (0 < list.length (sort LessEq s))) (length_sort LessEq)) h)) :=
  sorted_zero_eq_min'_aux s h
    (iff.mp card_pos (eq.mp (Eq._oldrec (Eq.refl (0 < list.length (sort LessEq s))) (length_sort LessEq)) h))

theorem min'_eq_sorted_zero {α : Type u_1} [linear_order α] {s : finset α} {h : finset.nonempty s} : min' s h =
  list.nth_le (sort LessEq s) 0
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 < list.length (sort LessEq s))) (length_sort LessEq))) (iff.mpr card_pos h)) :=
  Eq.symm
    (sorted_zero_eq_min'_aux s
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 < list.length (sort LessEq s))) (length_sort LessEq))) (iff.mpr card_pos h)) h)

theorem sorted_last_eq_max'_aux {α : Type u_1} [linear_order α] (s : finset α) (h : list.length (sort LessEq s) - 1 < list.length (sort LessEq s)) (H : finset.nonempty s) : list.nth_le (sort LessEq s) (list.length (sort LessEq s) - 1) h = max' s H := sorry

theorem sorted_last_eq_max' {α : Type u_1} [linear_order α] {s : finset α} {h : list.length (sort LessEq s) - 1 < list.length (sort LessEq s)} : list.nth_le (sort LessEq s) (list.length (sort LessEq s) - 1) h =
  max' s
    (iff.mp card_pos
      (lt_of_le_of_lt bot_le
        (eq.mp
          (Eq._oldrec (Eq.refl (list.length (sort LessEq s) - 1 < list.length (sort LessEq s))) (length_sort LessEq))
          h))) := sorry

theorem max'_eq_sorted_last {α : Type u_1} [linear_order α] {s : finset α} {h : finset.nonempty s} : max' s h =
  list.nth_le (sort LessEq s) (list.length (sort LessEq s) - 1)
    (eq.mpr
      (id
        ((fun (ᾰ ᾰ_1 : ℕ) (e_2 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : ℕ) (e_3 : ᾰ_2 = ᾰ_3) => congr (congr_arg Less e_2) e_3)
          (list.length (sort LessEq s) - 1) (card s - 1)
          ((fun (ᾰ ᾰ_1 : ℕ) (e_2 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : ℕ) (e_3 : ᾰ_2 = ᾰ_3) => congr (congr_arg Sub.sub e_2) e_3)
            (list.length (sort LessEq s)) (card s) (length_sort LessEq) 1 1 (Eq.refl 1))
          (list.length (sort LessEq s)) (card s) (length_sort LessEq)))
      (eq.mp (Eq.refl (card s - 1 < card s)) (nat.sub_lt (iff.mpr card_pos h) zero_lt_one))) := sorry

/-- Given a finset `s` of cardinality `k` in a linear order `α`, the map `order_iso_of_fin s h`
is the increasing bijection between `fin k` and `s` as an `order_iso`. Here, `h` is a proof that
the cardinality of `s` is `k`. We use this instead of an iso `fin s.card ≃o s` to avoid
casting issues in further uses of this function. -/
def order_iso_of_fin {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) : fin k ≃o ↥↑s :=
  order_iso.trans (fin.cast sorry)
    (order_iso.trans (list.sorted.nth_le_iso (sort LessEq s) (sort_sorted_lt s))
      (order_iso.set_congr (fun (x : α) => list.mem x (sort LessEq s)) ↑s sorry))

/-- Given a finset `s` of cardinality `k` in a linear order `α`, the map `order_emb_of_fin s h` is
the increasing bijection between `fin k` and `s` as an order embedding into `α`. Here, `h` is a
proof that the cardinality of `s` is `k`. We use this instead of an embedding `fin s.card ↪o α` to
avoid casting issues in further uses of this function. -/
def order_emb_of_fin {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) : fin k ↪o α :=
  rel_embedding.trans (order_iso.to_order_embedding (order_iso_of_fin s h))
    (order_embedding.subtype fun (x : α) => x ∈ ↑s)

@[simp] theorem coe_order_iso_of_fin_apply {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) (i : fin k) : ↑(coe_fn (order_iso_of_fin s h) i) = coe_fn (order_emb_of_fin s h) i :=
  rfl

theorem order_iso_of_fin_symm_apply {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) (x : ↥↑s) : ↑(coe_fn (order_iso.symm (order_iso_of_fin s h)) x) = list.index_of (↑x) (sort LessEq s) :=
  rfl

theorem order_emb_of_fin_apply {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) (i : fin k) : coe_fn (order_emb_of_fin s h) i =
  list.nth_le (sort LessEq s) (↑i)
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑i < list.length (sort LessEq s))) (length_sort LessEq)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑i < card s)) h)) (subtype.property i))) :=
  rfl

@[simp] theorem order_emb_of_fin_mem {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) (i : fin k) : coe_fn (order_emb_of_fin s h) i ∈ s :=
  subtype.property (coe_fn (order_iso_of_fin s h) i)

@[simp] theorem range_order_emb_of_fin {α : Type u_1} [linear_order α] (s : finset α) {k : ℕ} (h : card s = k) : set.range ⇑(order_emb_of_fin s h) = ↑s := sorry

/-- The bijection `order_emb_of_fin s h` sends `0` to the minimum of `s`. -/
theorem order_emb_of_fin_zero {α : Type u_1} [linear_order α] {s : finset α} {k : ℕ} (h : card s = k) (hz : 0 < k) : coe_fn (order_emb_of_fin s h) { val := 0, property := hz } = min' s (iff.mp card_pos (Eq.symm h ▸ hz)) := sorry

/-- The bijection `order_emb_of_fin s h` sends `k-1` to the maximum of `s`. -/
theorem order_emb_of_fin_last {α : Type u_1} [linear_order α] {s : finset α} {k : ℕ} (h : card s = k) (hz : 0 < k) : coe_fn (order_emb_of_fin s h) { val := k - 1, property := buffer.lt_aux_2 hz } =
  max' s (iff.mp card_pos (Eq.symm h ▸ hz)) := sorry

/-- `order_emb_of_fin {a} h` sends any argument to `a`. -/
@[simp] theorem order_emb_of_fin_singleton {α : Type u_1} [linear_order α] (a : α) (i : fin 1) : coe_fn (order_emb_of_fin (singleton a) (card_singleton a)) i = a := sorry

/-- Any increasing map `f` from `fin k` to a finset of cardinality `k` has to coincide with
the increasing bijection `order_emb_of_fin s h`. -/
theorem order_emb_of_fin_unique {α : Type u_1} [linear_order α] {s : finset α} {k : ℕ} (h : card s = k) {f : fin k → α} (hfs : ∀ (x : fin k), f x ∈ s) (hmono : strict_mono f) : f = ⇑(order_emb_of_fin s h) := sorry

/-- An order embedding `f` from `fin k` to a finset of cardinality `k` has to coincide with
the increasing bijection `order_emb_of_fin s h`. -/
theorem order_emb_of_fin_unique' {α : Type u_1} [linear_order α] {s : finset α} {k : ℕ} (h : card s = k) {f : fin k ↪o α} (hfs : ∀ (x : fin k), coe_fn f x ∈ s) : f = order_emb_of_fin s h :=
  rel_embedding.ext (iff.mp function.funext_iff (order_emb_of_fin_unique h hfs (order_embedding.strict_mono f)))

/-- Two parametrizations `order_emb_of_fin` of the same set take the same value on `i` and `j` if
and only if `i = j`. Since they can be defined on a priori not defeq types `fin k` and `fin l`
(although necessarily `k = l`), the conclusion is rather written `(i : ℕ) = (j : ℕ)`. -/
@[simp] theorem order_emb_of_fin_eq_order_emb_of_fin_iff {α : Type u_1} [linear_order α] {k : ℕ} {l : ℕ} {s : finset α} {i : fin k} {j : fin l} {h : card s = k} {h' : card s = l} : coe_fn (order_emb_of_fin s h) i = coe_fn (order_emb_of_fin s h') j ↔ ↑i = ↑j := sorry

protected instance has_repr {α : Type u_1} [has_repr α] : has_repr (finset α) :=
  has_repr.mk fun (s : finset α) => repr (val s)


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

! This file was ported from Lean 3 source module data.nat.bits
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Basic

/-!
# Additional properties of binary recursion on `nat`

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

This file documents additional properties of binary recursion,
which allows us to more easily work with operations which do depend
on the number of leading zeros in the binary representation of `n`.
For example, we can more easily work with `nat.bits` and `nat.size`.

See also: `nat.bitwise`, `nat.pow` (for various lemmas about `size` and `shiftl`/`shiftr`),
and `nat.digits`.
-/

namespace Nat

universe u

variable {n : ℕ}

/-! ### `bodd_div2` and `bodd` -/

#print Nat.boddDiv2_eq /-
@[simp]
theorem boddDiv2_eq (n : ℕ) : boddDiv2 n = (bodd n, div2 n) := by
  unfold bodd div2 <;> cases bodd_div2 n <;> rfl
#align nat.bodd_div2_eq Nat.boddDiv2_eq
-/

#print Nat.bodd_bit0 /-
@[simp]
theorem bodd_bit0 (n) : bodd (bit0 n) = false :=
  bodd_bit false n
#align nat.bodd_bit0 Nat.bodd_bit0
-/

#print Nat.bodd_bit1 /-
@[simp]
theorem bodd_bit1 (n) : bodd (bit1 n) = true :=
  bodd_bit true n
#align nat.bodd_bit1 Nat.bodd_bit1
-/

#print Nat.div2_bit0 /-
@[simp]
theorem div2_bit0 (n) : div2 (bit0 n) = n :=
  div2_bit false n
#align nat.div2_bit0 Nat.div2_bit0
-/

#print Nat.div2_bit1 /-
@[simp]
theorem div2_bit1 (n) : div2 (bit1 n) = n :=
  div2_bit true n
#align nat.div2_bit1 Nat.div2_bit1
-/

/-! ### `bit0` and `bit1` -/

#print Nat.bit0_eq_bit0 /-
-- There is no need to prove `bit0_eq_zero : bit0 n = 0 ↔ n = 0`
-- as this is true for any `[semiring R] [no_zero_divisors R] [char_zero R]`
-- However the lemmas `bit0_eq_bit0`, `bit1_eq_bit1`, `bit1_eq_one`, `one_eq_bit1`
-- need `[ring R] [no_zero_divisors R] [char_zero R]` in general,
-- so we prove `ℕ` specialized versions here.
@[simp]
theorem bit0_eq_bit0 {m n : ℕ} : bit0 m = bit0 n ↔ m = n :=
  ⟨Nat.bit0_inj, fun h => by subst h⟩
#align nat.bit0_eq_bit0 Nat.bit0_eq_bit0
-/

#print Nat.bit1_eq_bit1 /-
@[simp]
theorem bit1_eq_bit1 {m n : ℕ} : bit1 m = bit1 n ↔ m = n :=
  ⟨Nat.bit1_inj, fun h => by subst h⟩
#align nat.bit1_eq_bit1 Nat.bit1_eq_bit1
-/

#print Nat.bit1_eq_one /-
@[simp]
theorem bit1_eq_one {n : ℕ} : bit1 n = 1 ↔ n = 0 :=
  ⟨@Nat.bit1_inj n 0, fun h => by subst h⟩
#align nat.bit1_eq_one Nat.bit1_eq_one
-/

#print Nat.one_eq_bit1 /-
@[simp]
theorem one_eq_bit1 {n : ℕ} : 1 = bit1 n ↔ n = 0 :=
  ⟨fun h => (@Nat.bit1_inj 0 n h).symm, fun h => by subst h⟩
#align nat.one_eq_bit1 Nat.one_eq_bit1
-/

#print Nat.bit_add /-
theorem bit_add : ∀ (b : Bool) (n m : ℕ), bit b (n + m) = bit false n + bit b m
  | tt => bit1_add
  | ff => bit0_add
#align nat.bit_add Nat.bit_add
-/

#print Nat.bit_add' /-
theorem bit_add' : ∀ (b : Bool) (n m : ℕ), bit b (n + m) = bit b n + bit false m
  | tt => bit1_add'
  | ff => bit0_add
#align nat.bit_add' Nat.bit_add'
-/

#print Nat.bit_ne_zero /-
theorem bit_ne_zero (b) {n} (h : n ≠ 0) : bit b n ≠ 0 := by
  cases b <;> [exact Nat.bit0_ne_zero h, exact Nat.bit1_ne_zero _]
#align nat.bit_ne_zero Nat.bit_ne_zero
-/

#print Nat.bit0_mod_two /-
theorem bit0_mod_two : bit0 n % 2 = 0 :=
  by
  rw [Nat.mod_two_of_bodd]
  simp
#align nat.bit0_mod_two Nat.bit0_mod_two
-/

#print Nat.bit1_mod_two /-
theorem bit1_mod_two : bit1 n % 2 = 1 :=
  by
  rw [Nat.mod_two_of_bodd]
  simp
#align nat.bit1_mod_two Nat.bit1_mod_two
-/

#print Nat.pos_of_bit0_pos /-
theorem pos_of_bit0_pos {n : ℕ} (h : 0 < bit0 n) : 0 < n :=
  by
  cases n
  cases h
  apply succ_pos
#align nat.pos_of_bit0_pos Nat.pos_of_bit0_pos
-/

#print Nat.bitCasesOn_bit /-
@[simp]
theorem bitCasesOn_bit {C : ℕ → Sort u} (H : ∀ b n, C (bit b n)) (b : Bool) (n : ℕ) :
    bitCasesOn (bit b n) H = H b n :=
  eq_of_hEq <| (eq_rec_hEq _ _).trans <| by rw [bodd_bit, div2_bit]
#align nat.bit_cases_on_bit Nat.bitCasesOn_bit
-/

#print Nat.bitCasesOn_bit0 /-
@[simp]
theorem bitCasesOn_bit0 {C : ℕ → Sort u} (H : ∀ b n, C (bit b n)) (n : ℕ) :
    bitCasesOn (bit0 n) H = H false n :=
  bitCasesOn_bit H false n
#align nat.bit_cases_on_bit0 Nat.bitCasesOn_bit0
-/

#print Nat.bitCasesOn_bit1 /-
@[simp]
theorem bitCasesOn_bit1 {C : ℕ → Sort u} (H : ∀ b n, C (bit b n)) (n : ℕ) :
    bitCasesOn (bit1 n) H = H true n :=
  bitCasesOn_bit H true n
#align nat.bit_cases_on_bit1 Nat.bitCasesOn_bit1
-/

#print Nat.bit_cases_on_injective /-
theorem bit_cases_on_injective {C : ℕ → Sort u} :
    Function.Injective fun H : ∀ b n, C (bit b n) => fun n => bitCasesOn n H :=
  by
  intro H₁ H₂ h
  ext (b n)
  simpa only [bit_cases_on_bit] using congr_fun h (bit b n)
#align nat.bit_cases_on_injective Nat.bit_cases_on_injective
-/

#print Nat.bit_cases_on_inj /-
@[simp]
theorem bit_cases_on_inj {C : ℕ → Sort u} (H₁ H₂ : ∀ b n, C (bit b n)) :
    ((fun n => bitCasesOn n H₁) = fun n => bitCasesOn n H₂) ↔ H₁ = H₂ :=
  bit_cases_on_injective.eq_iff
#align nat.bit_cases_on_inj Nat.bit_cases_on_inj
-/

#print Nat.bit0_eq_zero /-
protected theorem bit0_eq_zero {n : ℕ} : bit0 n = 0 ↔ n = 0 :=
  ⟨Nat.eq_zero_of_add_eq_zero_left, fun h => by simp [h]⟩
#align nat.bit0_eq_zero Nat.bit0_eq_zero
-/

#print Nat.bit_eq_zero_iff /-
theorem bit_eq_zero_iff {n : ℕ} {b : Bool} : bit b n = 0 ↔ n = 0 ∧ b = false :=
  by
  constructor
  · cases b <;> simp [Nat.bit, Nat.bit0_eq_zero]
  rintro ⟨rfl, rfl⟩
  rfl
#align nat.bit_eq_zero_iff Nat.bit_eq_zero_iff
-/

#print Nat.binaryRec_eq' /-
/-- The same as binary_rec_eq, but that one unfortunately requires `f` to be the identity when
  appending `ff` to `0`. Here, we allow you to explicitly say that that case is not happening, i.e.
  supplying `n = 0 → b = tt`. -/
theorem binaryRec_eq' {C : ℕ → Sort _} {z : C 0} {f : ∀ b n, C n → C (bit b n)} (b n)
    (h : f false 0 z = z ∨ (n = 0 → b = true)) :
    binaryRec z f (bit b n) = f b n (binaryRec z f n) :=
  by
  rw [binary_rec]
  split_ifs with h'
  · rcases bit_eq_zero_iff.mp h' with ⟨rfl, rfl⟩
    rw [binary_rec_zero]
    simp only [imp_false, or_false_iff, eq_self_iff_true, not_true] at h
    exact h.symm
  · generalize_proofs e
    revert e
    rw [bodd_bit, div2_bit]
    intros
    rfl
#align nat.binary_rec_eq' Nat.binaryRec_eq'
-/

#print Nat.binaryRec' /-
/-- The same as `binary_rec`, but the induction step can assume that if `n=0`,
  the bit being appended is `tt`-/
@[elab_as_elim]
def binaryRec' {C : ℕ → Sort _} (z : C 0) (f : ∀ b n, (n = 0 → b = true) → C n → C (bit b n)) :
    ∀ n, C n :=
  binaryRec z fun b n ih =>
    if h : n = 0 → b = true then f b n h ih
    else by
      convert z
      rw [bit_eq_zero_iff]
      simpa using h
#align nat.binary_rec' Nat.binaryRec'
-/

#print Nat.binaryRecFromOne /-
/-- The same as `binary_rec`, but special casing both 0 and 1 as base cases -/
@[elab_as_elim]
def binaryRecFromOne {C : ℕ → Sort _} (z₀ : C 0) (z₁ : C 1) (f : ∀ b n, n ≠ 0 → C n → C (bit b n)) :
    ∀ n, C n :=
  binaryRec' z₀ fun b n h ih =>
    if h' : n = 0 then by
      rw [h', h h']
      exact z₁
    else f b n h' ih
#align nat.binary_rec_from_one Nat.binaryRecFromOne
-/

#print Nat.zero_bits /-
@[simp]
theorem zero_bits : bits 0 = [] := by simp [Nat.bits]
#align nat.zero_bits Nat.zero_bits
-/

#print Nat.bits_append_bit /-
@[simp]
theorem bits_append_bit (n : ℕ) (b : Bool) (hn : n = 0 → b = true) : (bit b n).bits = b :: n.bits :=
  by
  rw [Nat.bits, binary_rec_eq']
  simpa
#align nat.bits_append_bit Nat.bits_append_bit
-/

#print Nat.bit0_bits /-
@[simp]
theorem bit0_bits (n : ℕ) (hn : n ≠ 0) : (bit0 n).bits = false :: n.bits :=
  bits_append_bit n false fun hn' => absurd hn' hn
#align nat.bit0_bits Nat.bit0_bits
-/

#print Nat.bit1_bits /-
@[simp]
theorem bit1_bits (n : ℕ) : (bit1 n).bits = true :: n.bits :=
  bits_append_bit n true fun _ => rfl
#align nat.bit1_bits Nat.bit1_bits
-/

#print Nat.one_bits /-
@[simp]
theorem one_bits : Nat.bits 1 = [true] :=
  by
  convert bit1_bits 0
  simp
#align nat.one_bits Nat.one_bits
-/

#print Nat.bodd_eq_bits_head /-
-- TODO Find somewhere this can live.
-- example : bits 3423 = [tt, tt, tt, tt, tt, ff, tt, ff, tt, ff, tt, tt] := by norm_num
theorem bodd_eq_bits_head (n : ℕ) : n.bodd = n.bits.headI :=
  by
  induction' n using Nat.binaryRec' with b n h ih; · simp
  simp [bodd_bit, bits_append_bit _ _ h]
#align nat.bodd_eq_bits_head Nat.bodd_eq_bits_head
-/

#print Nat.div2_bits_eq_tail /-
theorem div2_bits_eq_tail (n : ℕ) : n.div2.bits = n.bits.tail :=
  by
  induction' n using Nat.binaryRec' with b n h ih; · simp
  simp [div2_bit, bits_append_bit _ _ h]
#align nat.div2_bits_eq_tail Nat.div2_bits_eq_tail
-/

end Nat