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

! This file was ported from Lean 3 source module linear_algebra.pi_tensor_product
! leanprover-community/mathlib commit ce11c3c2a285bbe6937e26d9792fda4e51f3fe1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Congruence
import Mathbin.LinearAlgebra.Multilinear.TensorProduct

/-!
# Tensor product of an indexed family of modules over commutative semirings

We define the tensor product of an indexed family `s : ι → Type*` of modules over commutative
semirings. We denote this space by `⨂[R] i, s i` and define it as `free_add_monoid (R × Π i, s i)`
quotiented by the appropriate equivalence relation. The treatment follows very closely that of the
binary tensor product in `linear_algebra/tensor_product.lean`.

## Main definitions

* `pi_tensor_product R s` with `R` a commutative semiring and `s : ι → Type*` is the tensor product
  of all the `s i`'s. This is denoted by `⨂[R] i, s i`.
* `tprod R f` with `f : Π i, s i` is the tensor product of the vectors `f i` over all `i : ι`.
  This is bundled as a multilinear map from `Π i, s i` to `⨂[R] i, s i`.
* `lift_add_hom` constructs an `add_monoid_hom` from `(⨂[R] i, s i)` to some space `F` from a
  function `φ : (R × Π i, s i) → F` with the appropriate properties.
* `lift φ` with `φ : multilinear_map R s E` is the corresponding linear map
  `(⨂[R] i, s i) →ₗ[R] E`. This is bundled as a linear equivalence.
* `pi_tensor_product.reindex e` re-indexes the components of `⨂[R] i : ι, M` along `e : ι ≃ ι₂`.
* `pi_tensor_product.tmul_equiv` equivalence between a `tensor_product` of `pi_tensor_product`s and
  a single `pi_tensor_product`.

## Notations

* `⨂[R] i, s i` is defined as localized notation in locale `tensor_product`
* `⨂ₜ[R] i, f i` with `f : Π i, f i` is defined globally as the tensor product of all the `f i`'s.

## Implementation notes

* We define it via `free_add_monoid (R × Π i, s i)` with the `R` representing a "hidden" tensor
  factor, rather than `free_add_monoid (Π i, s i)` to ensure that, if `ι` is an empty type,
  the space is isomorphic to the base ring `R`.
* We have not restricted the index type `ι` to be a `fintype`, as nothing we do here strictly
  requires it. However, problems may arise in the case where `ι` is infinite; use at your own
  caution.
* Instead of requiring `decidable_eq ι` as an argument to `pi_tensor_product` itself, we include it
  as an argument in the constructors of the relation. A decidability isntance still has to come
  from somewhere due to the use of `function.update`, but this hides it from the downstream user.
  See the implementation notes for `multilinear_map` for an extended discussion of this choice.

## TODO

* Define tensor powers, symmetric subspace, etc.
* API for the various ways `ι` can be split into subsets; connect this with the binary
  tensor product.
* Include connection with holors.
* Port more of the API from the binary tensor product over to this case.

## Tags

multilinear, tensor, tensor product
-/

open Function

section Semiring

variable {ι ι₂ ι₃ : Type _}

variable {R : Type _} [CommSemiring R]

variable {R₁ R₂ : Type _}

variable {s : ι → Type _} [∀ i, AddCommMonoid (s i)] [∀ i, Module R (s i)]

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

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

variable {F : Type _} [AddCommMonoid F]

namespace PiTensorProduct

include R

variable (R) (s)

/-- The relation on `free_add_monoid (R × Π i, s i)` that generates a congruence whose quotient is
the tensor product. -/
inductive Eqv : FreeAddMonoid (R × ∀ i, s i) → FreeAddMonoid (R × ∀ i, s i) → Prop
  | of_zero : ∀ (r : R) (f : ∀ i, s i) (i : ι) (hf : f i = 0), eqv (FreeAddMonoid.of (r, f)) 0
  | of_zero_scalar : ∀ f : ∀ i, s i, eqv (FreeAddMonoid.of (0, f)) 0
  |
  of_add :
    ∀ (inst : DecidableEq ι) (r : R) (f : ∀ i, s i) (i : ι) (m₁ m₂ : s i),
      eqv (FreeAddMonoid.of (r, update f i m₁) + FreeAddMonoid.of (r, update f i m₂))
        (FreeAddMonoid.of (r, update f i (m₁ + m₂)))
  |
  of_add_scalar :
    ∀ (r r' : R) (f : ∀ i, s i),
      eqv (FreeAddMonoid.of (r, f) + FreeAddMonoid.of (r', f)) (FreeAddMonoid.of (r + r', f))
  |
  of_smul :
    ∀ (inst : DecidableEq ι) (r : R) (f : ∀ i, s i) (i : ι) (r' : R),
      eqv (FreeAddMonoid.of (r, update f i (r' • f i))) (FreeAddMonoid.of (r' * r, f))
  | add_comm : ∀ x y, eqv (x + y) (y + x)
#align pi_tensor_product.eqv PiTensorProduct.Eqv

end PiTensorProduct

variable (R) (s)

/-- `pi_tensor_product R s` with `R` a commutative semiring and `s : ι → Type*` is the tensor
  product of all the `s i`'s. This is denoted by `⨂[R] i, s i`. -/
def PiTensorProduct : Type _ :=
  (addConGen (PiTensorProduct.Eqv R s)).Quotient
#align pi_tensor_product PiTensorProduct

variable {R}

-- mathport name: pi_tensor_product
-- This enables the notation `⨂[R] i : ι, s i` for the pi tensor product, given `s : ι → Type*`.
scoped[TensorProduct] notation3:100"⨂["R"] "(...)", "r:(scoped f => PiTensorProduct R f) => r

open TensorProduct

namespace PiTensorProduct

section Module

instance : AddCommMonoid (⨂[R] i, s i) :=
  { (addConGen (PiTensorProduct.Eqv R s)).AddMonoid with
    add_comm := fun x y =>
      AddCon.induction_on₂ x y fun x y =>
        Quotient.sound' <| AddConGen.Rel.of _ _ <| Eqv.add_comm _ _ }

instance : Inhabited (⨂[R] i, s i) :=
  ⟨0⟩

variable (R) {s}

/-- `tprod_coeff R r f` with `r : R` and `f : Π i, s i` is the tensor product of the vectors `f i`
over all `i : ι`, multiplied by the coefficient `r`. Note that this is meant as an auxiliary
definition for this file alone, and that one should use `tprod` defined below for most purposes. -/
def tprodCoeff (r : R) (f : ∀ i, s i) : ⨂[R] i, s i :=
  AddCon.mk' _ <| FreeAddMonoid.of (r, f)
#align pi_tensor_product.tprod_coeff PiTensorProduct.tprodCoeff

variable {R}

theorem zero_tprodCoeff (f : ∀ i, s i) : tprodCoeff R 0 f = 0 :=
  Quotient.sound' <| AddConGen.Rel.of _ _ <| Eqv.of_zero_scalar _
#align pi_tensor_product.zero_tprod_coeff PiTensorProduct.zero_tprodCoeff

theorem zero_tprod_coeff' (z : R) (f : ∀ i, s i) (i : ι) (hf : f i = 0) : tprodCoeff R z f = 0 :=
  Quotient.sound' <| AddConGen.Rel.of _ _ <| Eqv.of_zero _ _ i hf
#align pi_tensor_product.zero_tprod_coeff' PiTensorProduct.zero_tprod_coeff'

theorem add_tprodCoeff [DecidableEq ι] (z : R) (f : ∀ i, s i) (i : ι) (m₁ m₂ : s i) :
    tprodCoeff R z (update f i m₁) + tprodCoeff R z (update f i m₂) =
      tprodCoeff R z (update f i (m₁ + m₂)) :=
  Quotient.sound' <| AddConGen.Rel.of _ _ (Eqv.of_add _ z f i m₁ m₂)
#align pi_tensor_product.add_tprod_coeff PiTensorProduct.add_tprodCoeff

theorem add_tprod_coeff' (z₁ z₂ : R) (f : ∀ i, s i) :
    tprodCoeff R z₁ f + tprodCoeff R z₂ f = tprodCoeff R (z₁ + z₂) f :=
  Quotient.sound' <| AddConGen.Rel.of _ _ (Eqv.of_add_scalar z₁ z₂ f)
#align pi_tensor_product.add_tprod_coeff' PiTensorProduct.add_tprod_coeff'

theorem smul_tprodCoeff_aux [DecidableEq ι] (z : R) (f : ∀ i, s i) (i : ι) (r : R) :
    tprodCoeff R z (update f i (r • f i)) = tprodCoeff R (r * z) f :=
  Quotient.sound' <| AddConGen.Rel.of _ _ <| Eqv.of_smul _ _ _ _ _
#align pi_tensor_product.smul_tprod_coeff_aux PiTensorProduct.smul_tprodCoeff_aux

theorem smul_tprodCoeff [DecidableEq ι] (z : R) (f : ∀ i, s i) (i : ι) (r : R₁) [SMul R₁ R]
    [IsScalarTower R₁ R R] [SMul R₁ (s i)] [IsScalarTower R₁ R (s i)] :
    tprodCoeff R z (update f i (r • f i)) = tprodCoeff R (r • z) f :=
  by
  have h₁ : r • z = r • (1 : R) * z := by rw [smul_mul_assoc, one_mul]
  have h₂ : r • f i = (r • (1 : R)) • f i := (smul_one_smul _ _ _).symm
  rw [h₁, h₂]
  exact smul_tprod_coeff_aux z f i _
#align pi_tensor_product.smul_tprod_coeff PiTensorProduct.smul_tprodCoeff

/-- Construct an `add_monoid_hom` from `(⨂[R] i, s i)` to some space `F` from a function
`φ : (R × Π i, s i) → F` with the appropriate properties. -/
def liftAddHom (φ : (R × ∀ i, s i) → F)
    (C0 : ∀ (r : R) (f : ∀ i, s i) (i : ι) (hf : f i = 0), φ (r, f) = 0)
    (C0' : ∀ f : ∀ i, s i, φ (0, f) = 0)
    (C_add :
      ∀ [DecidableEq ι] (r : R) (f : ∀ i, s i) (i : ι) (m₁ m₂ : s i),
        φ (r, update f i m₁) + φ (r, update f i m₂) = φ (r, update f i (m₁ + m₂)))
    (C_add_scalar : ∀ (r r' : R) (f : ∀ i, s i), φ (r, f) + φ (r', f) = φ (r + r', f))
    (C_smul :
      ∀ [DecidableEq ι] (r : R) (f : ∀ i, s i) (i : ι) (r' : R),
        φ (r, update f i (r' • f i)) = φ (r' * r, f)) :
    (⨂[R] i, s i) →+ F :=
  (addConGen (PiTensorProduct.Eqv R s)).lift (FreeAddMonoid.lift φ) <|
    AddCon.addConGen_le fun x y hxy =>
      match x, y, hxy with
      | _, _, eqv.of_zero r' f i hf =>
        (AddCon.ker_rel _).2 <| by simp [FreeAddMonoid.lift_eval_of, C0 r' f i hf]
      | _, _, eqv.of_zero_scalar f =>
        (AddCon.ker_rel _).2 <| by simp [FreeAddMonoid.lift_eval_of, C0']
      | _, _, eqv.of_add inst z f i m₁ m₂ =>
        (AddCon.ker_rel _).2 <| by simp [FreeAddMonoid.lift_eval_of, @C_add inst]
      | _, _, eqv.of_add_scalar z₁ z₂ f =>
        (AddCon.ker_rel _).2 <| by simp [FreeAddMonoid.lift_eval_of, C_add_scalar]
      | _, _, eqv.of_smul inst z f i r' =>
        (AddCon.ker_rel _).2 <| by simp [FreeAddMonoid.lift_eval_of, @C_smul inst]
      | _, _, eqv.add_comm x y =>
        (AddCon.ker_rel _).2 <| by simp_rw [AddMonoidHom.map_add, add_comm]
#align pi_tensor_product.lift_add_hom PiTensorProduct.liftAddHom

@[elab_as_elim]
protected theorem induction_on' {C : (⨂[R] i, s i) → Prop} (z : ⨂[R] i, s i)
    (C1 : ∀ {r : R} {f : ∀ i, s i}, C (tprodCoeff R r f)) (Cp : ∀ {x y}, C x → C y → C (x + y)) :
    C z :=
  by
  have C0 : C 0 := by
    have h₁ := @C1 0 0
    rwa [zero_tprod_coeff] at h₁
  refine' AddCon.induction_on z fun x => FreeAddMonoid.recOn x C0 _
  simp_rw [AddCon.coe_add]
  refine' fun f y ih => Cp _ ih
  convert@C1 f.1 f.2
  simp only [Prod.mk.eta]
#align pi_tensor_product.induction_on' PiTensorProduct.induction_on'

section DistribMulAction

variable [Monoid R₁] [DistribMulAction R₁ R] [SMulCommClass R₁ R R]

variable [Monoid R₂] [DistribMulAction R₂ R] [SMulCommClass R₂ R R]

-- Most of the time we want the instance below this one, which is easier for typeclass resolution
-- to find.
instance hasSmul' : SMul R₁ (⨂[R] i, s i) :=
  ⟨fun r =>
    liftAddHom (fun f : R × ∀ i, s i => tprodCoeff R (r • f.1) f.2)
      (fun r' f i hf => by simp_rw [zero_tprod_coeff' _ f i hf])
      (fun f => by simp [zero_tprod_coeff]) (fun r' f i m₁ m₂ => by simp [add_tprod_coeff])
      (fun r' r'' f => by simp [add_tprod_coeff', mul_add]) fun z f i r' => by
      simp [smul_tprod_coeff, mul_smul_comm]⟩
#align pi_tensor_product.has_smul' PiTensorProduct.hasSmul'

instance : SMul R (⨂[R] i, s i) :=
  PiTensorProduct.hasSmul'

theorem smul_tprod_coeff' (r : R₁) (z : R) (f : ∀ i, s i) :
    r • tprodCoeff R z f = tprodCoeff R (r • z) f :=
  rfl
#align pi_tensor_product.smul_tprod_coeff' PiTensorProduct.smul_tprod_coeff'

protected theorem smul_add (r : R₁) (x y : ⨂[R] i, s i) : r • (x + y) = r • x + r • y :=
  AddMonoidHom.map_add _ _ _
#align pi_tensor_product.smul_add PiTensorProduct.smul_add

instance distribMulAction' : DistribMulAction R₁ (⨂[R] i, s i)
    where
  smul := (· • ·)
  smul_add r x y := AddMonoidHom.map_add _ _ _
  mul_smul r r' x :=
    PiTensorProduct.induction_on' x (fun r'' f => by simp [smul_tprod_coeff', smul_smul])
      fun x y ihx ihy => by simp_rw [PiTensorProduct.smul_add, ihx, ihy]
  one_smul x :=
    PiTensorProduct.induction_on' x (fun f => by simp [smul_tprod_coeff' _ _]) fun z y ihz ihy => by
      simp_rw [PiTensorProduct.smul_add, ihz, ihy]
  smul_zero r := AddMonoidHom.map_zero _
#align pi_tensor_product.distrib_mul_action' PiTensorProduct.distribMulAction'

instance smul_comm_class' [SMulCommClass R₁ R₂ R] : SMulCommClass R₁ R₂ (⨂[R] i, s i) :=
  ⟨fun r' r'' x =>
    PiTensorProduct.induction_on' x (fun xr xf => by simp only [smul_tprod_coeff', smul_comm])
      fun z y ihz ihy => by simp_rw [PiTensorProduct.smul_add, ihz, ihy]⟩
#align pi_tensor_product.smul_comm_class' PiTensorProduct.smul_comm_class'

instance is_scalar_tower' [SMul R₁ R₂] [IsScalarTower R₁ R₂ R] :
    IsScalarTower R₁ R₂ (⨂[R] i, s i) :=
  ⟨fun r' r'' x =>
    PiTensorProduct.induction_on' x (fun xr xf => by simp only [smul_tprod_coeff', smul_assoc])
      fun z y ihz ihy => by simp_rw [PiTensorProduct.smul_add, ihz, ihy]⟩
#align pi_tensor_product.is_scalar_tower' PiTensorProduct.is_scalar_tower'

end DistribMulAction

-- Most of the time we want the instance below this one, which is easier for typeclass resolution
-- to find.
instance module' [Semiring R₁] [Module R₁ R] [SMulCommClass R₁ R R] : Module R₁ (⨂[R] i, s i) :=
  { PiTensorProduct.distribMulAction' with
    smul := (· • ·)
    add_smul := fun r r' x =>
      PiTensorProduct.induction_on' x
        (fun r f => by simp [smul_tprod_coeff' _ _, add_smul, add_tprod_coeff']) fun x y ihx ihy =>
        by simp [PiTensorProduct.smul_add, ihx, ihy, add_add_add_comm]
    zero_smul := fun x =>
      PiTensorProduct.induction_on' x
        (fun r f => by
          simp_rw [smul_tprod_coeff' _ _, zero_smul]
          exact zero_tprod_coeff _)
        fun x y ihx ihy => by rw [PiTensorProduct.smul_add, ihx, ihy, add_zero] }
#align pi_tensor_product.module' PiTensorProduct.module'

-- shortcut instances
instance : Module R (⨂[R] i, s i) :=
  PiTensorProduct.module'

instance : SMulCommClass R R (⨂[R] i, s i) :=
  PiTensorProduct.smul_comm_class'

instance : IsScalarTower R R (⨂[R] i, s i) :=
  PiTensorProduct.is_scalar_tower'

variable {R}

variable (R)

/-- The canonical `multilinear_map R s (⨂[R] i, s i)`. -/
def tprod : MultilinearMap R s (⨂[R] i, s i)
    where
  toFun := tprodCoeff R 1
  map_add' _ f i x y := (add_tprod_coeff (1 : R) f i x y).symm
  map_smul' _ f i r x := by
    skip <;> simp_rw [smul_tprod_coeff', ← smul_tprod_coeff (1 : R) _ i, update_idem, update_same]
#align pi_tensor_product.tprod PiTensorProduct.tprod

variable {R}

-- mathport name: «expr⨂ₜ[ ] , »
notation3:100"⨂ₜ["R"] "(...)", "r:(scoped f => tprod R f) => r

@[simp]
theorem tprodCoeff_eq_smul_tprod (z : R) (f : ∀ i, s i) : tprodCoeff R z f = z • tprod R f :=
  by
  have : z = z • (1 : R) := by simp only [mul_one, Algebra.id.smul_eq_mul]
  conv_lhs => rw [this]
  rw [← smul_tprod_coeff']
  rfl
#align pi_tensor_product.tprod_coeff_eq_smul_tprod PiTensorProduct.tprodCoeff_eq_smul_tprod

@[elab_as_elim]
protected theorem induction_on {C : (⨂[R] i, s i) → Prop} (z : ⨂[R] i, s i)
    (C1 : ∀ {r : R} {f : ∀ i, s i}, C (r • tprod R f)) (Cp : ∀ {x y}, C x → C y → C (x + y)) :
    C z := by
  simp_rw [← tprod_coeff_eq_smul_tprod] at C1
  exact PiTensorProduct.induction_on' z @C1 @Cp
#align pi_tensor_product.induction_on PiTensorProduct.induction_on

@[ext]
theorem ext {φ₁ φ₂ : (⨂[R] i, s i) →ₗ[R] E}
    (H : φ₁.compMultilinearMap (tprod R) = φ₂.compMultilinearMap (tprod R)) : φ₁ = φ₂ :=
  by
  refine' LinearMap.ext _
  refine' fun z =>
    PiTensorProduct.induction_on' z _ fun x y hx hy => by rw [φ₁.map_add, φ₂.map_add, hx, hy]
  · intro r f
    rw [tprod_coeff_eq_smul_tprod, φ₁.map_smul, φ₂.map_smul]
    apply _root_.congr_arg
    exact MultilinearMap.congr_fun H f
#align pi_tensor_product.ext PiTensorProduct.ext

end Module

section Multilinear

open MultilinearMap

variable {s}

/-- Auxiliary function to constructing a linear map `(⨂[R] i, s i) → E` given a
`multilinear map R s E` with the property that its composition with the canonical
`multilinear_map R s (⨂[R] i, s i)` is the given multilinear map. -/
def liftAux (φ : MultilinearMap R s E) : (⨂[R] i, s i) →+ E :=
  liftAddHom (fun p : R × ∀ i, s i => p.1 • φ p.2)
    (fun z f i hf => by rw [map_coord_zero φ i hf, smul_zero]) (fun f => by rw [zero_smul])
    (fun _ z f i m₁ m₂ => by
      skip
      rw [← smul_add, φ.map_add])
    (fun z₁ z₂ f => by rw [← add_smul]) fun _ z f i r =>
    by
    skip
    simp [φ.map_smul, smul_smul, mul_comm]
#align pi_tensor_product.lift_aux PiTensorProduct.liftAux

theorem liftAux_tprod (φ : MultilinearMap R s E) (f : ∀ i, s i) : liftAux φ (tprod R f) = φ f := by
  simp only [lift_aux, lift_add_hom, tprod, MultilinearMap.coe_mk, tprod_coeff,
    FreeAddMonoid.lift_eval_of, one_smul, AddCon.lift_mk']
#align pi_tensor_product.lift_aux_tprod PiTensorProduct.liftAux_tprod

theorem liftAux_tprodCoeff (φ : MultilinearMap R s E) (z : R) (f : ∀ i, s i) :
    liftAux φ (tprodCoeff R z f) = z • φ f := by
  simp [lift_aux, lift_add_hom, tprod_coeff, FreeAddMonoid.lift_eval_of]
#align pi_tensor_product.lift_aux_tprod_coeff PiTensorProduct.liftAux_tprodCoeff

theorem liftAux.smul {φ : MultilinearMap R s E} (r : R) (x : ⨂[R] i, s i) :
    liftAux φ (r • x) = r • liftAux φ x :=
  by
  refine' PiTensorProduct.induction_on' x _ _
  · intro z f
    rw [smul_tprod_coeff' r z f, lift_aux_tprod_coeff, lift_aux_tprod_coeff, smul_assoc]
  · intro z y ihz ihy
    rw [smul_add, (lift_aux φ).map_add, ihz, ihy, (lift_aux φ).map_add, smul_add]
#align pi_tensor_product.lift_aux.smul PiTensorProduct.liftAux.smul

/-- Constructing a linear map `(⨂[R] i, s i) → E` given a `multilinear_map R s E` with the
property that its composition with the canonical `multilinear_map R s E` is
the given multilinear map `φ`. -/
def lift : MultilinearMap R s E ≃ₗ[R] (⨂[R] i, s i) →ₗ[R] E
    where
  toFun φ := { liftAux φ with map_smul' := liftAux.smul }
  invFun φ' := φ'.compMultilinearMap (tprod R)
  left_inv φ := by
    ext
    simp [lift_aux_tprod, LinearMap.compMultilinearMap]
  right_inv φ := by
    ext
    simp [lift_aux_tprod]
  map_add' φ₁ φ₂ := by
    ext
    simp [lift_aux_tprod]
  map_smul' r φ₂ := by
    ext
    simp [lift_aux_tprod]
#align pi_tensor_product.lift PiTensorProduct.lift

variable {φ : MultilinearMap R s E}

@[simp]
theorem lift.tprod (f : ∀ i, s i) : lift φ (tprod R f) = φ f :=
  liftAux_tprod φ f
#align pi_tensor_product.lift.tprod PiTensorProduct.lift.tprod

theorem lift.unique' {φ' : (⨂[R] i, s i) →ₗ[R] E} (H : φ'.compMultilinearMap (tprod R) = φ) :
    φ' = lift φ :=
  ext <| H.symm ▸ (lift.symm_apply_apply φ).symm
#align pi_tensor_product.lift.unique' PiTensorProduct.lift.unique'

theorem lift.unique {φ' : (⨂[R] i, s i) →ₗ[R] E} (H : ∀ f, φ' (tprod R f) = φ f) : φ' = lift φ :=
  lift.unique' (MultilinearMap.ext H)
#align pi_tensor_product.lift.unique PiTensorProduct.lift.unique

@[simp]
theorem lift_symm (φ' : (⨂[R] i, s i) →ₗ[R] E) : lift.symm φ' = φ'.compMultilinearMap (tprod R) :=
  rfl
#align pi_tensor_product.lift_symm PiTensorProduct.lift_symm

@[simp]
theorem lift_tprod : lift (tprod R : MultilinearMap R s _) = LinearMap.id :=
  Eq.symm <| lift.unique' rfl
#align pi_tensor_product.lift_tprod PiTensorProduct.lift_tprod

section

variable (R M)

/-- Re-index the components of the tensor power by `e`.

For simplicity, this is defined only for homogeneously- (rather than dependently-) typed components.
-/
def reindex (e : ι ≃ ι₂) : (⨂[R] i : ι, M) ≃ₗ[R] ⨂[R] i : ι₂, M :=
  LinearEquiv.ofLinear (lift (domDomCongr e.symm (tprod R : MultilinearMap R _ (⨂[R] i : ι₂, M))))
    (lift (domDomCongr e (tprod R : MultilinearMap R _ (⨂[R] i : ι, M))))
    (by
      ext
      simp only [LinearMap.comp_apply, LinearMap.id_apply, lift_tprod,
        LinearMap.compMultilinearMap_apply, lift.tprod, dom_dom_congr_apply,
        Equiv.apply_symm_apply])
    (by
      ext
      simp only [LinearMap.comp_apply, LinearMap.id_apply, lift_tprod,
        LinearMap.compMultilinearMap_apply, lift.tprod, dom_dom_congr_apply,
        Equiv.symm_apply_apply])
#align pi_tensor_product.reindex PiTensorProduct.reindex

end

@[simp]
theorem reindex_tprod (e : ι ≃ ι₂) (f : ∀ i, M) :
    reindex R M e (tprod R f) = tprod R fun i => f (e.symm i) :=
  liftAux_tprod _ f
#align pi_tensor_product.reindex_tprod PiTensorProduct.reindex_tprod

@[simp]
theorem reindex_comp_tprod (e : ι ≃ ι₂) :
    (reindex R M e : (⨂[R] i : ι, M) →ₗ[R] ⨂[R] i : ι₂, M).compMultilinearMap (tprod R) =
      (tprod R : MultilinearMap R (fun i => M) _).domDomCongr e.symm :=
  MultilinearMap.ext <| reindex_tprod e
#align pi_tensor_product.reindex_comp_tprod PiTensorProduct.reindex_comp_tprod

@[simp]
theorem lift_comp_reindex (e : ι ≃ ι₂) (φ : MultilinearMap R (fun _ : ι₂ => M) E) :
    lift φ ∘ₗ ↑(reindex R M e) = lift (φ.domDomCongr e.symm) :=
  by
  ext
  simp
#align pi_tensor_product.lift_comp_reindex PiTensorProduct.lift_comp_reindex

@[simp]
theorem lift_reindex (e : ι ≃ ι₂) (φ : MultilinearMap R (fun _ => M) E) (x : ⨂[R] i, M) :
    lift φ (reindex R M e x) = lift (φ.domDomCongr e.symm) x :=
  LinearMap.congr_fun (lift_comp_reindex e φ) x
#align pi_tensor_product.lift_reindex PiTensorProduct.lift_reindex

@[simp]
theorem reindex_trans (e : ι ≃ ι₂) (e' : ι₂ ≃ ι₃) :
    (reindex R M e).trans (reindex R M e') = reindex R M (e.trans e') :=
  by
  apply LinearEquiv.toLinearMap_injective
  ext f
  simp only [LinearEquiv.trans_apply, LinearEquiv.coe_coe, reindex_tprod,
    LinearMap.coe_compMultilinearMap, Function.comp_apply, MultilinearMap.domDomCongr_apply,
    reindex_comp_tprod]
  congr
#align pi_tensor_product.reindex_trans PiTensorProduct.reindex_trans

@[simp]
theorem reindex_reindex (e : ι ≃ ι₂) (e' : ι₂ ≃ ι₃) (x : ⨂[R] i, M) :
    reindex R M e' (reindex R M e x) = reindex R M (e.trans e') x :=
  LinearEquiv.congr_fun (reindex_trans e e' : _ = reindex R M (e.trans e')) x
#align pi_tensor_product.reindex_reindex PiTensorProduct.reindex_reindex

@[simp]
theorem reindex_symm (e : ι ≃ ι₂) : (reindex R M e).symm = reindex R M e.symm :=
  rfl
#align pi_tensor_product.reindex_symm PiTensorProduct.reindex_symm

@[simp]
theorem reindex_refl : reindex R M (Equiv.refl ι) = LinearEquiv.refl R _ :=
  by
  apply LinearEquiv.toLinearMap_injective
  ext1
  rw [reindex_comp_tprod, LinearEquiv.refl_toLinearMap, Equiv.refl_symm]
  rfl
#align pi_tensor_product.reindex_refl PiTensorProduct.reindex_refl

variable (ι)

/-- The tensor product over an empty index type `ι` is isomorphic to the base ring. -/
@[simps symm_apply]
def isEmptyEquiv [IsEmpty ι] : (⨂[R] i : ι, M) ≃ₗ[R] R
    where
  toFun := lift (constOfIsEmpty R _ 1)
  invFun r := r • tprod R (@isEmptyElim _ _ _)
  left_inv x := by
    apply x.induction_on
    · intro r f
      have := Subsingleton.elim f isEmptyElim
      simp [this]
    · simp only
      intro x y hx hy
      simp [add_smul, hx, hy]
  right_inv t := by
    simp only [mul_one, Algebra.id.smul_eq_mul, const_of_is_empty_apply, LinearMap.map_smul,
      PiTensorProduct.lift.tprod]
  map_add' := LinearMap.map_add _
  map_smul' := LinearMap.map_smul _
#align pi_tensor_product.is_empty_equiv PiTensorProduct.isEmptyEquiv

@[simp]
theorem isEmptyEquiv_apply_tprod [IsEmpty ι] (f : ι → M) : isEmptyEquiv ι (tprod R f) = 1 :=
  lift.tprod _
#align pi_tensor_product.is_empty_equiv_apply_tprod PiTensorProduct.isEmptyEquiv_apply_tprod

variable {ι}

/-- The tensor product over an single index is isomorphic to the module -/
@[simps symm_apply]
def subsingletonEquiv [Subsingleton ι] (i₀ : ι) : (⨂[R] i : ι, M) ≃ₗ[R] M
    where
  toFun := lift (MultilinearMap.ofSubsingleton R M i₀)
  invFun m := tprod R fun v => m
  left_inv x := by
    dsimp only
    have : ∀ (f : ι → M) (z : M), (fun i : ι => z) = update f i₀ z :=
      by
      intro f z
      ext i
      rw [Subsingleton.elim i i₀, Function.update_same]
    apply x.induction_on
    · intro r f
      simp only [LinearMap.map_smul, lift.tprod, of_subsingleton_apply, Function.eval, this f,
        MultilinearMap.map_smul, update_eq_self]
    · intro x y hx hy
      simp only [MultilinearMap.map_add, this 0 (_ + _), LinearMap.map_add, ← this 0 (lift _ _), hx,
        hy]
  right_inv t := by simp only [of_subsingleton_apply, lift.tprod, Function.eval_apply]
  map_add' := LinearMap.map_add _
  map_smul' := LinearMap.map_smul _
#align pi_tensor_product.subsingleton_equiv PiTensorProduct.subsingletonEquiv

@[simp]
theorem subsingletonEquiv_apply_tprod [Subsingleton ι] (i : ι) (f : ι → M) :
    subsingletonEquiv i (tprod R f) = f i :=
  lift.tprod _
#align pi_tensor_product.subsingleton_equiv_apply_tprod PiTensorProduct.subsingletonEquiv_apply_tprod

section Tmul

/-- Collapse a `tensor_product` of `pi_tensor_product`s. -/
private def tmul : ((⨂[R] i : ι, M) ⊗[R] ⨂[R] i : ι₂, M) →ₗ[R] ⨂[R] i : Sum ι ι₂, M :=
  TensorProduct.lift
    { toFun := fun a =>
        PiTensorProduct.lift <|
          PiTensorProduct.lift (MultilinearMap.currySumEquiv R _ _ M _ (tprod R)) a
      map_add' := fun a b => by simp only [LinearEquiv.map_add, LinearMap.map_add]
      map_smul' := fun r a => by
        simp only [LinearEquiv.map_smul, LinearMap.map_smul, RingHom.id_apply] }
#align pi_tensor_product.tmul pi_tensor_product.tmul

private theorem tmul_apply (a : ι → M) (b : ι₂ → M) :
    tmul ((⨂ₜ[R] i, a i) ⊗ₜ[R] ⨂ₜ[R] i, b i) = ⨂ₜ[R] i, Sum.elim a b i :=
  by
  erw [TensorProduct.lift.tmul, PiTensorProduct.lift.tprod, PiTensorProduct.lift.tprod]
  rfl
#align pi_tensor_product.tmul_apply pi_tensor_product.tmul_apply

/-- Expand `pi_tensor_product` into a `tensor_product` of two factors. -/
private def tmul_symm : (⨂[R] i : Sum ι ι₂, M) →ₗ[R] (⨂[R] i : ι, M) ⊗[R] ⨂[R] i : ι₂, M :=
  -- by using tactic mode, we avoid the need for a lot of `@`s and `_`s
    PiTensorProduct.lift <|
    by apply MultilinearMap.domCoprod <;> [exact tprod R, exact tprod R]
#align pi_tensor_product.tmul_symm pi_tensor_product.tmul_symm

private theorem tmul_symm_apply (a : Sum ι ι₂ → M) :
    tmulSymm (⨂ₜ[R] i, a i) = (⨂ₜ[R] i, a (Sum.inl i)) ⊗ₜ[R] ⨂ₜ[R] i, a (Sum.inr i) :=
  PiTensorProduct.lift.tprod _
#align pi_tensor_product.tmul_symm_apply pi_tensor_product.tmul_symm_apply

variable (R M)

attribute [local ext] TensorProduct.ext

/-- Equivalence between a `tensor_product` of `pi_tensor_product`s and a single
`pi_tensor_product` indexed by a `sum` type.

For simplicity, this is defined only for homogeneously- (rather than dependently-) typed components.
-/
def tmulEquiv : ((⨂[R] i : ι, M) ⊗[R] ⨂[R] i : ι₂, M) ≃ₗ[R] ⨂[R] i : Sum ι ι₂, M :=
  LinearEquiv.ofLinear tmul tmulSymm
    (by
      ext x
      show tmul (tmul_symm (tprod R x)) = tprod R x
      -- Speed up the call to `simp`.
      simp only [tmul_symm_apply, tmul_apply, Sum.elim_comp_inl_inr])
    (by
      ext (x y)
      show tmul_symm (tmul (tprod R x ⊗ₜ[R] tprod R y)) = tprod R x ⊗ₜ[R] tprod R y
      simp only [tmul_apply, tmul_symm_apply, Sum.elim_inl, Sum.elim_inr])
#align pi_tensor_product.tmul_equiv PiTensorProduct.tmulEquiv

@[simp]
theorem tmulEquiv_apply (a : ι → M) (b : ι₂ → M) :
    tmulEquiv R M ((⨂ₜ[R] i, a i) ⊗ₜ[R] ⨂ₜ[R] i, b i) = ⨂ₜ[R] i, Sum.elim a b i :=
  tmul_apply a b
#align pi_tensor_product.tmul_equiv_apply PiTensorProduct.tmulEquiv_apply

@[simp]
theorem tmulEquiv_symm_apply (a : Sum ι ι₂ → M) :
    (tmulEquiv R M).symm (⨂ₜ[R] i, a i) = (⨂ₜ[R] i, a (Sum.inl i)) ⊗ₜ[R] ⨂ₜ[R] i, a (Sum.inr i) :=
  tmulSymm_apply a
#align pi_tensor_product.tmul_equiv_symm_apply PiTensorProduct.tmulEquiv_symm_apply

end Tmul

end Multilinear

end PiTensorProduct

end Semiring

section Ring

namespace PiTensorProduct

open PiTensorProduct

open TensorProduct

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

variable {s : ι → Type _} [∀ i, AddCommGroup (s i)] [∀ i, Module R (s i)]

/- Unlike for the binary tensor product, we require `R` to be a `comm_ring` here, otherwise
this is false in the case where `ι` is empty. -/
instance : AddCommGroup (⨂[R] i, s i) :=
  Module.addCommMonoidToAddCommGroup R

end PiTensorProduct

end Ring


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

import ring_theory.eisenstein_criterion

/-!
# Eisenstein polynomials
Given an ideal `𝓟` of a commutative semiring `R`, we say that a polynomial `f : polynomial R` is
*Eisenstein at `𝓟`* if `f.leading_coeff ∉ 𝓟`, `∀ n, n < f.nat_degree → f.coeff n ∈ 𝓟` and
`f.coeff 0 ∉ 𝓟 ^ 2`. In this file we gather miscellaneous results about Eisenstein polynomials.

## Main definitions
* `polynomial.is_eisenstein_at f 𝓟` : the property of being Eisenstein at `𝓟`.

## Main results
* `polynomial.is_eisenstein_at.irreducible` : if a primitive `f` satisfies `f.is_eisenstein_at 𝓟`,
  where `𝓟.is_prime`, then `f` is irreducible.

## Implementation details
We also define a notion `is_weakly_eisenstein_at` requiring only that
`∀ n < f.nat_degree → f.coeff n ∈ 𝓟`. This makes certain results slightly more general and it is
useful since it is sometimes better behaved (for example it is stable under `polynomial.map`).

-/

universes u v

variables {R : Type u}

open ideal algebra finset

open_locale big_operators

namespace polynomial

/-- Given an ideal `𝓟` of a commutative semiring `R`, we say that a polynomial `f : polynomial R`
is *weakly Eisenstein at `𝓟`* if `∀ n, n < f.nat_degree → f.coeff n ∈ 𝓟`. -/
@[mk_iff] structure is_weakly_eisenstein_at [comm_semiring R] (f : polynomial R) (𝓟 : ideal R) :
  Prop := (mem : ∀ {n}, n < f.nat_degree → f.coeff n ∈ 𝓟)

/-- Given an ideal `𝓟` of a commutative semiring `R`, we say that a polynomial `f : polynomial R`
is *Eisenstein at `𝓟`* if `f.leading_coeff ∉ 𝓟`, `∀ n, n < f.nat_degree → f.coeff n ∈ 𝓟` and
`f.coeff 0 ∉ 𝓟 ^ 2`. -/
@[mk_iff] structure is_eisenstein_at [comm_semiring R] (f : polynomial R) (𝓟 : ideal R) : Prop :=
(leading : f.leading_coeff ∉ 𝓟)
(mem : ∀ {n}, n < f.nat_degree → f.coeff n ∈ 𝓟)
(not_mem : f.coeff 0 ∉ 𝓟 ^ 2)

namespace is_weakly_eisenstein_at

section comm_semiring

variables [comm_semiring R] {𝓟 : ideal R} {f : polynomial R} (hf : f.is_weakly_eisenstein_at 𝓟)

include hf

lemma map {A : Type v} [comm_ring A] (φ : R →+* A) : (f.map φ).is_weakly_eisenstein_at (𝓟.map φ) :=
begin
  refine (is_weakly_eisenstein_at_iff _ _).2 (λ n hn, _),
  rw [coeff_map],
  exact mem_map_of_mem _ (hf.mem (lt_of_lt_of_le hn (nat_degree_map_le _ _)))
end

end comm_semiring

section comm_ring

variables [comm_ring R] {𝓟 : ideal R} {f : polynomial R} (hf : f.is_weakly_eisenstein_at 𝓟)
variables {S : Type v} [comm_ring S] [algebra R S]

section principal

variable {p : R}

local notation `P` := submodule.span R {p}

lemma exists_mem_adjoin_mul_eq_pow_nat_degree {x : S} (hx : aeval x f = 0)
  (hmo : f.monic) (hf : f.is_weakly_eisenstein_at P) : ∃ y ∈ adjoin R ({x} : set S),
  (algebra_map R S) p * y = x ^ (f.map (algebra_map R S)).nat_degree :=
begin
  rw [aeval_def, polynomial.eval₂_eq_eval_map, eval_eq_finset_sum, range_add_one,
    sum_insert not_mem_range_self, sum_range, (monic_map
    (algebra_map R S) hmo).coeff_nat_degree, one_mul] at hx,
  replace hx := eq_neg_of_add_eq_zero hx,
  have : ∀ n < f.nat_degree, p ∣ f.coeff n,
  { intros n hn,
    refine mem_span_singleton.1 (by simpa using hf.mem hn) },
  choose! φ hφ using this,
  conv_rhs at hx { congr, congr, skip, funext,
    rw [fin.coe_eq_val, coeff_map, hφ i.1 (lt_of_lt_of_le i.2 (nat_degree_map_le _ _)),
      ring_hom.map_mul, mul_assoc] },
  rw [hx, ← mul_sum, neg_eq_neg_one_mul, ← mul_assoc (-1 : S), mul_comm (-1 : S), mul_assoc],
  refine ⟨-1 * ∑ (i : fin (f.map (algebra_map R S)).nat_degree),
    (algebra_map R S) (φ i.1) * x ^ i.1, _, rfl⟩,
  exact subalgebra.mul_mem _ (subalgebra.neg_mem _ (subalgebra.one_mem _))
    (subalgebra.sum_mem _ (λ i hi, subalgebra.mul_mem _ (subalgebra.algebra_map_mem _ _)
    (subalgebra.pow_mem _ (subset_adjoin (set.mem_singleton x)) _)))
end

lemma exists_mem_adjoin_mul_eq_pow_nat_degree_le {x : S} (hx : aeval x f = 0)
  (hmo : f.monic) (hf : f.is_weakly_eisenstein_at P) :
  ∀ i, (f.map (algebra_map R S)).nat_degree ≤ i →
  ∃ y ∈ adjoin R ({x} : set S), (algebra_map R S) p * y = x ^ i :=
begin
  intros i hi,
  obtain ⟨k, hk⟩ := le_iff_exists_add.1 hi,
  rw [hk, pow_add],
  obtain ⟨y, hy, H⟩ := exists_mem_adjoin_mul_eq_pow_nat_degree hx hmo hf,
  refine ⟨y * x ^ k, _, _⟩,
  { exact subalgebra.mul_mem _ hy (subalgebra.pow_mem _  (subset_adjoin (set.mem_singleton x)) _) },
  { rw [← mul_assoc _ y, H] }
end

end principal

include hf

lemma pow_nat_degree_le_of_root_of_monic_mem {x : R} (hroot : is_root f x) (hmo : f.monic) :
  ∀ i, f.nat_degree ≤ i → x ^ i ∈ 𝓟 :=
begin
  intros i hi,
  obtain ⟨k, hk⟩ := le_iff_exists_add.1 hi,
  rw [hk, pow_add],
  suffices : x ^ f.nat_degree ∈ 𝓟,
  { exact mul_mem_right (x ^ k) 𝓟 this },
  rw [is_root.def, eval_eq_finset_sum, finset.range_add_one, finset.sum_insert
    finset.not_mem_range_self, finset.sum_range, hmo.coeff_nat_degree, one_mul] at hroot,
  rw [eq_neg_of_add_eq_zero hroot, neg_mem_iff],
  refine submodule.sum_mem _ (λ i hi,  mul_mem_right _ _ (hf.mem (fin.is_lt i)))
end

lemma pow_nat_degree_le_of_aeval_zero_of_monic_mem_map {x : S} (hx : aeval x f = 0)
  (hmo : f.monic) :
  ∀ i, (f.map (algebra_map R S)).nat_degree ≤ i → x ^ i ∈ 𝓟.map (algebra_map R S) :=
begin
  suffices : x ^ (f.map (algebra_map R S)).nat_degree ∈ 𝓟.map (algebra_map R S),
  { intros i hi,
    obtain ⟨k, hk⟩ := le_iff_exists_add.1 hi,
    rw [hk, pow_add],
    refine mul_mem_right _ _ this },
  rw [aeval_def, eval₂_eq_eval_map, ← is_root.def] at hx,
  refine pow_nat_degree_le_of_root_of_monic_mem (hf.map _) hx (monic_map _ hmo) _ rfl.le
end

end comm_ring

end is_weakly_eisenstein_at

namespace is_eisenstein_at

section comm_semiring

variables [comm_semiring R] {𝓟 : ideal R} {f : polynomial R} (hf : f.is_eisenstein_at 𝓟)

include hf

lemma is_weakly_eisenstein_at : is_weakly_eisenstein_at f 𝓟 := ⟨hf.mem⟩

lemma coeff_mem {n : ℕ} (hn : n ≠ f.nat_degree) : f.coeff n ∈ 𝓟 :=
begin
  cases ne_iff_lt_or_gt.1 hn,
  { exact hf.mem h },
  { rw [coeff_eq_zero_of_nat_degree_lt h],
    exact ideal.zero_mem _}
end

end comm_semiring

section is_domain

variables [comm_ring R] [is_domain R] {𝓟 : ideal R} {f : polynomial R} (hf : f.is_eisenstein_at 𝓟)

/-- If a primitive `f` satisfies `f.is_eisenstein_at 𝓟`, where `𝓟.is_prime`, then `f` is
irreducible. -/
lemma irreducible (hprime : 𝓟.is_prime) (hu : f.is_primitive)
  (hfd0 : 0 < f.nat_degree) : irreducible f :=
irreducible_of_eisenstein_criterion hprime hf.leading (λ n hn, hf.mem (coe_lt_degree.1 hn))
  (nat_degree_pos_iff_degree_pos.1 hfd0) hf.not_mem hu

end is_domain

end is_eisenstein_at

end polynomial


import data.int.basic
import algebra.ring.boolean_ring

lemma obvious_fact_1 (n : ℤ): n ≥ 1 → ∀ (x : ℤ), x + n ≠ x :=
assume h: n ≥ 1,
assume x,
show x + n ≠ x, from
(
  assume hc: x + n = x,
  have hn0: n = 0, from
  (
    calc
    n   = 0 + n : by rw zero_add
    ... = (-x + x) + n : by rw add_left_neg
    ... = -x + (x + n) : by rw add_assoc
    ... = -x + x : by rw hc
    ... = 0 : by rw add_left_neg
  ),
  have h1leq0Z: ↑1 ≤ ↑0, by from @eq.subst _ ((≤) 1) _ _ hn0 h,
  have h1leq0: 1 ≤ 0, from iff.elim_left int.coe_nat_lt h1leq0Z,
  have h1geq0: 1 ≥ 0, from zero_le_one,
  have h1eq0: 1 = 0, from ge_antisymm h1geq0 h1leq0,
  absurd h1eq0 one_ne_zero
)

lemma helper_fact (a : ℤ) (b : ℤ) (n : ℤ) (x : ℤ) (y: ℤ)
    (h: a * x + b * y = n): n = a * (x - b) + b * (y + a) :=
have h1: a * x + b * y = b * y + a * x,
    from add_comm (a * x) (b * y),
have h2: - (a * b) + b * a + b * y + a * x = - (a * b) + b * a + (b * y + a * x),
    from add_assoc (- (a * b) + b * a) (b * y) (a * x),
have h3: - (a * b) + b * a + b * y = - (a * b) + (b * a + b * y),
    from add_assoc (- (a * b)) (b * a) (b * y),
have h4: - (a * b) + (b * a + b * y) = (b * a + b * y) + (- (a * b)),
    from add_comm (- (a * b)) (b * a + b * y),
have h5: - (a * b) + a * x = a * x + (- (a * b)),
    from add_comm (- (a * b)) (a * x),
have h6: a + y = y + a, from add_comm a y,
have h7: a * x + (- (a * b)) = a * x - a * b,
    from sub_eq_add_neg (a * x) (a * b),
have h8: a * (x - b) = a * x - a * b, from
(
    have hh1: a * (x + (-b)) = a * x + a * (-b), from left_distrib a x (-b),
    have hh2: x + (-b) = x - b, from sub_eq_add_neg x b,
    show a * (x - b) = a * x - a * b, by simp * at *
),
calc
n   = a * x + b * y : by rw h
... = 0 + a * x + b * y : by rw zero_add
... = (- (a * b) + a * b) + a * x + b * y : by rw add_left_neg
... = (- (a * b) + b * a) + a * x + b * y : by rw mul_comm
... = (- (a * b) + b * a) + (a * x + b * y): by rw add_assoc
... = (- (a * b) + b * a) + (b * y + a * x) : by rw h1
... = - (a * b) + b * a + (b * y + a * x) : by rw add_assoc
... = - (a * b) + b * a + b * y + a * x : by rw h2
... = - (a * b) + (b * a + b * y) + a * x : by rw h3
... = (b * a + b * y) + (- (a * b)) + a * x : by rw h4
... = (b * a + b * y) + (- (a * b) + a * x) : by rw add_assoc
... = b * (a + y) + (- (a * b) + a * x) : by rw left_distrib
... = b * (a + y) + (a * x + (- (a * b))) : by rw h5
... = b * (y + a) + (a * x + (- (a * b))) : by rw h6
... = b * (y + a) + (a * x - a * b) : by rw h7
... = b * (y + a) + a * (x - b) : by rw h8
... = a * (x - b) + b * (y + a) : by rw add_comm

lemma obvious_fact_2 (c : ℤ): c + c = 2 * c :=
calc
c + c = 1 * c + 1 * c : by rw one_mul
    ... = (1 + 1) * c   : by rw right_distrib
    ... = 2 * c         : rfl

lemma helper_fact_2 (a : ℤ) (b : ℤ) (n : ℤ) (x : ℤ) (y : ℤ)
    (h: a ≥ 1 ∧ b ≥ 1 ∧ a * x + b * y = n ∧ n > 2 * a * b - a - b):
        x ≥ b ∨ y ≥ a :=
by_contradiction
(
  assume hc: ¬ (x ≥ b ∨ y ≥ a),
  have hc1: ¬ x ≥ b ∧ ¬ y ≥ a,
      from iff.elim_left (decidable.not_or_iff_and_not (x ≥ b) (y ≥ a)) hc,
  have h_xb: x < b, by simp * at *,
  have h_ya: y < a, by simp * at *,
  have h_xb1: x ≤ b - 1, from int.le_sub_one_of_lt h_xb,
  have h_ya1: y ≤ a - 1, from int.le_sub_one_of_lt h_ya,
  have a_pos: a ≥ 0, from int.le_trans zero_le_one h.1,
  have h_ax_ab1: a * x ≤ a * (b - 1),
      from mul_le_mul_of_nonneg_left h_xb1 a_pos,
  have b_pos: b ≥ 0, from int.le_trans zero_le_one h.2.1,
  have h_by_ba1: b * y ≤ b * (a - 1),
      from mul_le_mul_of_nonneg_left h_ya1 b_pos,
  have h_leq: a * x + b * y ≤ a * (b - 1) + b * (a - 1),
      from int.add_le_add h_ax_ab1 h_by_ba1,
  have h_2ab_ab: a * (b - 1) + b * (a - 1) = 2 * a * b - a - b,
      from
  (
    have hhh1: a * (b - 1) = a * b - a, by exact mul_sub_one a b,
    have hhh2: b * (a - 1) = b * a - b, by exact mul_sub_one b a,
    have hhh3: b * a = a * b, from mul_comm b a,
    have hhh4: b * a - b = a * b - b, by rw hhh3,
    have hhh5: b * (a - 1) = a * b - b, from eq.trans hhh2 hhh4,
    have hhh7: a * b + a * b = 2 * (a * b), from obvious_fact_2 (a * b),
    have hhh8: 2 * a * b = 2 * (a * b), by rw mul_assoc,
    have hhh9: a * b + a * b = 2 * a * b, from eq.trans hhh7 hhh8.symm,
    have hhh10: a * b + (a * b - b) = a * b + a * b - b,
        by exact add_sub (a * b) (a * b) b,
    calc
    a * (b - 1) + b * (a - 1) = a * b - a + b * (a - 1) : by rw hhh1
    ... = a * b - a + (a * b - b) : by rw hhh5
    ... = a * b + (a * b - b) - a : by exact sub_add_eq_add_sub (a * b) a (a * b - b)
    ... = a * b + a * b - b - a : by rw hhh10
    ... = a * b + a * b - a - b : by exact sub_right_comm (a * b + a * b) b a
    ... = 2 * a * b - a - b : by rw hhh9
  ),
  have h_leq2: a * x + b * y ≤ 2 * a * b - a - b, by simp * at *,
  have h_nleq: n ≤ 2 * a * b - a - b, by simp * at *,
  have h_not_n_ge: ¬ n > 2 * a * b - a - b, from
  (
    assume hhc: n > 2 * a * b - a - b,
    have hh1: n ≥ 2 * a * b - a - b, from int.le_of_lt hhc,
    have hh2: n = 2 * a * b - a - b, from int.le_antisymm h_nleq hh1,
    have hh3: 2 * a * b - a - b ≠ n, from int.ne_of_lt hhc,
    absurd hh2.symm hh3
  ),
  absurd h.2.2.2 h_not_n_ge
)

theorem Lemma_1_61 (a b n x y : ℤ)
(h_sol_xy: a * x + b * y = n)
(a_pos: a ≥ 1)
(b_pos: b ≥ 1)
(x_nneg: x ≥ 0)
(y_nneg: y ≥ 0)
(n_geq: n > 2 * a * b - a - b)
:
∃ (x1 : ℤ), ∃ (y1 : ℤ),
    (x1 ≥ 0 ∧ y1 ≥ 0 ∧ a * x1 + b * y1 = n ∧ (x1 ≠ x ∨ y1 ≠ y)) :=
have h_alt1: a * (x - b) + b * (y + a) = n,
    from (helper_fact a b n x y h_sol_xy).symm,
have h_alt2: a * (x + b) + b * (y - a) = n, from
(
  have h_comm: b * y + a * x = a * x + b * y, from add_comm (b * y) (a * x),
  have h_sol_comm: b * y + a * x = n, from eq.trans h_comm h_sol_xy,
  have hsymm: b * (y - a) + a * (x + b) = n,
      from (helper_fact b a n y x h_sol_comm).symm,
  have h_comm_2: b * (y - a) + a * (x + b) = a * (x + b) + b * (y - a),
      from add_comm (b * (y - a)) (a * (x + b)),
  show a * (x + b) + b * (y - a) = n, from eq.trans h_comm_2.symm hsymm
),
have h_xgeqb_or_ygeq_a: x ≥ b ∨ y ≥ a,
    from (helper_fact_2 a b n x y
            (and.intro a_pos (and.intro b_pos (and.intro h_sol_xy n_geq)))),
have h_xb_neq_x: x + b ≠ x, from obvious_fact_1 b b_pos x,
have h_ya_neq_y: y + a ≠ y, from obvious_fact_1 a a_pos y,
or.elim h_xgeqb_or_ygeq_a
(
  assume h_xgeqb: x ≥ b,
  show ∃ (x1 : ℤ), ∃ (y1 : ℤ),
      (x1 ≥ 0 ∧ y1 ≥ 0 ∧ a * x1 + b * y1 = n ∧ (x1 ≠ x ∨ y1 ≠ y)), from
  exists.intro (x - b)
  (
    exists.intro (y + a)
    (
      have hxb: x - b ≥ 0, by simp * at *,
      have hya: y + a ≥ 0, from
      (
        have h0a: 0 ≤ a, from le_trans zero_le_one a_pos,
        have h00a: a + 0 ≤ a + y, from add_le_add_left y_nneg a,
        have h_a_leq_a0: a ≤ a + 0, by simp * at *,
        have h_a_leq_ay: a ≤ a + y, from le_trans h_a_leq_a0 h00a,
        have hhhh: a ≤ y + a, by simp * at *,
        show 0 ≤ y + a, from le_trans h0a hhhh
      ),
      have h_different: x - b ≠ x ∨ y + a ≠ y, from
        or.intro_right (x - b ≠ x) h_ya_neq_y,
      and.intro hxb (and.intro hya (and.intro h_alt1 h_different))
    )
  )
)
(
  assume h_ygeqa: y ≥ a,
  show ∃ (x1 : ℤ), ∃ (y1 : ℤ),
      (x1 ≥ 0 ∧ y1 ≥ 0 ∧ a * x1 + b * y1 = n ∧ (x1 ≠ x ∨ y1 ≠ y)), from
  exists.intro (x + b)
  (
    exists.intro (y - a)
    (
      have hxb: x + b ≥ 0, from
      (
        have h0b: 0 ≤ b, from le_trans zero_le_one b_pos,
        have h00b: b + 0 ≤ b + x, from add_le_add_left x_nneg b,
        have h_b_leq_b0: b ≤ b + 0, by simp * at *,
        have h_b_leq_bx: b ≤ b + x, from le_trans h_b_leq_b0 h00b,
        have hhhh: b ≤ x + b, by simp * at *,
        show 0 ≤ x + b, from le_trans h0b hhhh
      ),
      have hya: y - a ≥ 0, by simp * at *,
      have h_different: x + b ≠ x ∨ y - a ≠ y, from
        or.intro_left (y - a ≠ y) h_xb_neq_x,
      and.intro hxb (and.intro hya (and.intro h_alt2 h_different))
    )
  )
)


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

! This file was ported from Lean 3 source module data.dfinsupp.well_founded
! leanprover-community/mathlib commit e9b8651eb1ad354f4de6be35a38ef31efcd2cfaa
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Dfinsupp.Lex
import Mathlib.Order.GameAdd
import Mathlib.Order.Antisymmetrization
import Mathlib.SetTheory.Ordinal.Basic

/-!
# Well-foundedness of the lexicographic and product orders on `Dfinsupp` and `Pi`

The primary results are `Dfinsupp.Lex.wellFounded` and the two variants that follow it,
which essentially say that if `(· > ·)` is a well order on `ι`, `(· < ·)` is well-founded on each
`α i`, and `0` is a bottom element in `α i`, then the lexicographic `(· < ·)` is well-founded
on `Π₀ i, α i`. The proof is modelled on the proof of `WellFounded.cutExpand`.

The results are used to prove `Pi.Lex.wellFounded` and two variants, which say that if
`ι` is finite and equipped with a linear order and `(· < ·)` is well-founded on each `α i`,
then the lexicographic `(· < ·)` is well-founded on `Π i, α i`, and the same is true for
`Π₀ i, α i` (`Dfinsupp.Lex.wellFounded_of_finite`), because `Dfinsupp` is order-isomorphic
to `pi` when `ι` is finite.

Finally, we deduce `Dfinsupp.wellFoundedLT`, `Pi.wellFoundedLT`,
`Dfinsupp.wellFoundedLT_of_finite` and variants, which concern the product order
rather than the lexicographic one. An order on `ι` is not required in these results,
but we deduce them from the well-foundedness of the lexicographic order by choosing
a well order on `ι` so that the product order `(· < ·)` becomes a subrelation
of the lexicographic `(· < ·)`.

All results are provided in two forms whenever possible: a general form where the relations
can be arbitrary (not the `(· < ·)` of a preorder, or not even transitive, etc.) and a specialized
form provided as `WellFoundedLT` instances where the `(d)Finsupp/pi` type (or their `Lex`
type synonyms) carries a natural `(· < ·)`.

Notice that the definition of `Dfinsupp.Lex` says that `x < y` according to `Dfinsupp.Lex r s`
iff there exists a coordinate `i : ι` such that `x i < y i` according to `s i`, and at all
`r`-smaller coordinates `j` (i.e. satisfying `r j i`), `x` remains unchanged relative to `y`;
in other words, coordinates `j` such that `¬ r j i` and `j ≠ i` are exactly where changes
can happen arbitrarily. This explains the appearance of `rᶜ ⊓ (≠)` in
`dfinsupp.acc_single` and `dfinsupp.well_founded`. When `r` is trichotomous (e.g. the `(· < ·)`
of a linear order), `¬ r j i ∧ j ≠ i` implies `r i j`, so it suffices to require `r.swap`
to be well-founded.
-/

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

namespace Dfinsupp

open Relation Prod

section Zero

variable [∀ i, Zero (α i)] (r : ι → ι → Prop) (s : ∀ i, α i → α i → Prop)

/-- This key lemma says that if a finitely supported dependent function `x₀` is obtained by merging
  two such functions `x₁` and `x₂`, and if we evolve `x₀` down the `Dfinsupp.Lex` relation one
  step and get `x`, we can always evolve one of `x₁` and `x₂` down the `Dfinsupp.Lex` relation
  one step while keeping the other unchanged, and merge them back (possibly in a different way)
  to get back `x`. In other words, the two parts evolve essentially independently under
  `Dfinsupp.Lex`. This is used to show that a function `x` is accessible if
  `Dfinsupp.single i (x i)` is accessible for each `i` in the (finite) support of `x`
  (`Dfinsupp.Lex.acc_of_single`). -/
theorem lex_fibration [∀ (i) (s : Set ι), Decidable (i ∈ s)] :
    Fibration (InvImage (GameAdd (Dfinsupp.Lex r s) (Dfinsupp.Lex r s)) snd) (Dfinsupp.Lex r s)
      fun x => piecewise x.2.1 x.2.2 x.1 := by
  rintro ⟨p, x₁, x₂⟩ x ⟨i, hr, hs⟩
  simp_rw [piecewise_apply] at hs hr
  split_ifs at hs with hp
  · refine ⟨⟨{ j | r j i → j ∈ p }, piecewise x₁ x { j | r j i }, x₂⟩,
      .fst ⟨i, fun j hj ↦ ?_, ?_⟩, ?_⟩ <;> simp only [piecewise_apply, Set.mem_setOf_eq]
    · simp only [if_pos hj]
    · split_ifs with hi
      · rwa [hr i hi, if_pos hp] at hs
      · assumption
    · ext1 j
      simp only [piecewise_apply, Set.mem_setOf_eq]
      split_ifs with h₁ h₂ <;> try rfl
      · rw [hr j h₂, if_pos (h₁ h₂)]
      · rw [not_imp] at h₁
        rw [hr j h₁.1, if_neg h₁.2]
  · refine ⟨⟨{ j | r j i ∧ j ∈ p }, x₁, piecewise x₂ x { j | r j i }⟩,
      .snd ⟨i, fun j hj ↦ ?_, ?_⟩, ?_⟩ <;> simp only [piecewise_apply, Set.mem_setOf_eq]
    · exact if_pos hj
    · split_ifs with hi
      · rwa [hr i hi, if_neg hp] at hs
      · assumption
    · ext1 j
      simp only [piecewise_apply, Set.mem_setOf_eq]
      split_ifs with h₁ h₂ <;> try rfl
      · rw [hr j h₁.1, if_pos h₁.2]
      · rw [hr j h₂, if_neg]
        simpa [h₂] using h₁
#align dfinsupp.lex_fibration Dfinsupp.lex_fibration

variable {r s}

theorem Lex.acc_of_single_erase [DecidableEq ι] {x : Π₀ i, α i} (i : ι)
    (hs : Acc (Dfinsupp.Lex r s) <| single i (x i)) (hu : Acc (Dfinsupp.Lex r s) <| x.erase i) :
    Acc (Dfinsupp.Lex r s) x := by
  classical
    convert ← @Acc.of_fibration _ _ _ _ _ (lex_fibration r s) ⟨{i}, _⟩
      (InvImage.accessible snd <| hs.prod_gameAdd hu)
    convert piecewise_single_erase x i
#align dfinsupp.lex.acc_of_single_erase Dfinsupp.Lex.acc_of_single_erase

variable (hbot : ∀ ⦃i a⦄, ¬s i a 0)

theorem Lex.acc_zero : Acc (Dfinsupp.Lex r s) 0 :=
  Acc.intro 0 fun _ ⟨_, _, h⟩ => (hbot h).elim
#align dfinsupp.lex.acc_zero Dfinsupp.Lex.acc_zero

theorem Lex.acc_of_single [DecidableEq ι] [∀ (i) (x : α i), Decidable (x ≠ 0)] (x : Π₀ i, α i) :
    (∀ i ∈ x.support, Acc (Dfinsupp.Lex r s) <| single i (x i)) → Acc (Dfinsupp.Lex r s) x := by
  generalize ht : x.support = t; revert x
  classical
    induction' t using Finset.induction with b t hb ih
    · intro x ht
      rw [support_eq_empty.1 ht]
      exact fun _ => Lex.acc_zero hbot
    refine' fun x ht h => Lex.acc_of_single_erase b (h b <| t.mem_insert_self b) _
    refine' ih _ (by rw [support_erase, ht, Finset.erase_insert hb]) fun a ha => _
    rw [erase_ne (ha.ne_of_not_mem hb)]
    exact h a (Finset.mem_insert_of_mem ha)
#align dfinsupp.lex.acc_of_single Dfinsupp.Lex.acc_of_single

variable (hs : ∀ i, WellFounded (s i))

theorem Lex.acc_single [DecidableEq ι] {i : ι} (hi : Acc (rᶜ ⊓ (· ≠ ·)) i) :
    ∀ a, Acc (Dfinsupp.Lex r s) (single i a) := by
  induction' hi with i _ ih
  refine fun a => WellFounded.induction (hs i)
    (C := fun x ↦ Acc (Dfinsupp.Lex r s) (single i x)) a fun a ha ↦ ?_
  refine Acc.intro _ fun x ↦ ?_
  rintro ⟨k, hr, hs⟩
  rw [single_apply] at hs
  split_ifs at hs with hik
  swap
  · exact (hbot hs).elim
  subst hik
  classical
    refine Lex.acc_of_single hbot x fun j hj ↦ ?_
    obtain rfl | hij := eq_or_ne i j
    · exact ha _ hs
    by_cases r j i
    · rw [hr j h, single_eq_of_ne hij, single_zero]
      exact Lex.acc_zero hbot
    · exact ih _ ⟨h, hij.symm⟩ _
#align dfinsupp.lex.acc_single Dfinsupp.Lex.acc_single

theorem Lex.acc [DecidableEq ι] [∀ (i) (x : α i), Decidable (x ≠ 0)] (x : Π₀ i, α i)
    (h : ∀ i ∈ x.support, Acc (rᶜ ⊓ (· ≠ ·)) i) : Acc (Dfinsupp.Lex r s) x :=
  Lex.acc_of_single hbot x fun i hi => Lex.acc_single hbot hs (h i hi) _
#align dfinsupp.lex.acc Dfinsupp.Lex.acc

theorem Lex.wellFounded (hr : WellFounded <| rᶜ ⊓ (· ≠ ·)) : WellFounded (Dfinsupp.Lex r s) :=
  ⟨fun x => by classical exact Lex.acc hbot hs x fun i _ => hr.apply i⟩
#align dfinsupp.lex.well_founded Dfinsupp.Lex.wellFounded

theorem Lex.wellFounded' [IsTrichotomous ι r] (hr : WellFounded (Function.swap r)) :
    WellFounded (Dfinsupp.Lex r s) :=
  Lex.wellFounded hbot hs <| Subrelation.wf
   (fun {i j} h => ((@IsTrichotomous.trichotomous ι r _ i j).resolve_left h.1).resolve_left h.2) hr
#align dfinsupp.lex.well_founded' Dfinsupp.Lex.wellFounded'

end Zero

instance Lex.wellFoundedLT [LT ι] [IsTrichotomous ι (· < ·)] [hι : WellFoundedGT ι]
    [∀ i, CanonicallyOrderedAddMonoid (α i)] [hα : ∀ i, WellFoundedLT (α i)] :
    WellFoundedLT (Lex (Π₀ i, α i)) :=
  ⟨Lex.wellFounded' (fun _ a => (zero_le a).not_lt) (fun i => (hα i).wf) hι.wf⟩
#align dfinsupp.lex.well_founded_lt Dfinsupp.Lex.wellFoundedLT

end Dfinsupp

open Dfinsupp

variable (r : ι → ι → Prop) {s : ∀ i, α i → α i → Prop}

theorem Pi.Lex.wellFounded [IsStrictTotalOrder ι r] [Finite ι] (hs : ∀ i, WellFounded (s i)) :
    WellFounded (Pi.Lex r (fun {i} ↦ s i)) := by
  obtain h | ⟨⟨x⟩⟩ := isEmpty_or_nonempty (∀ i, α i)
  · convert emptyWf.wf
  letI : ∀ i, Zero (α i) := fun i => ⟨(hs i).min ⊤ ⟨x i, trivial⟩⟩
  haveI := IsTrans.swap r; haveI := IsIrrefl.swap r; haveI := Fintype.ofFinite ι
  refine' InvImage.wf equivFunOnFintype.symm (Lex.wellFounded' (fun i a => _) hs _)
  exacts [(hs i).not_lt_min ⊤ _ trivial, Finite.wellFounded_of_trans_of_irrefl (Function.swap r)]
#align pi.lex.well_founded Pi.Lex.wellFounded

instance Pi.Lex.wellFoundedLT [LinearOrder ι] [Finite ι] [∀ i, LT (α i)]
    [hwf : ∀ i, WellFoundedLT (α i)] : WellFoundedLT (Lex (∀ i, α i)) :=
  ⟨Pi.Lex.wellFounded (· < ·) fun i => (hwf i).1⟩
#align pi.lex.well_founded_lt Pi.Lex.wellFoundedLT

instance Function.Lex.wellFoundedLT {α} [LinearOrder ι] [Finite ι] [LT α] [WellFoundedLT α] :
    WellFoundedLT (Lex (ι → α)) :=
  Pi.Lex.wellFoundedLT
#align function.lex.well_founded_lt Function.Lex.wellFoundedLT

theorem Dfinsupp.Lex.wellFounded_of_finite [IsStrictTotalOrder ι r] [Finite ι] [∀ i, Zero (α i)]
    (hs : ∀ i, WellFounded (s i)) : WellFounded (Dfinsupp.Lex r s) :=
  have := Fintype.ofFinite ι
  InvImage.wf equivFunOnFintype (Pi.Lex.wellFounded r hs)
#align dfinsupp.lex.well_founded_of_finite Dfinsupp.Lex.wellFounded_of_finite

instance Dfinsupp.Lex.wellFoundedLT_of_finite [LinearOrder ι] [Finite ι] [∀ i, Zero (α i)]
    [∀ i, LT (α i)] [hwf : ∀ i, WellFoundedLT (α i)] : WellFoundedLT (Lex (Π₀ i, α i)) :=
  ⟨Dfinsupp.Lex.wellFounded_of_finite (· < ·) fun i => (hwf i).1⟩
#align dfinsupp.lex.well_founded_lt_of_finite Dfinsupp.Lex.wellFoundedLT_of_finite

protected theorem Dfinsupp.wellFoundedLT [∀ i, Zero (α i)] [∀ i, Preorder (α i)]
    [∀ i, WellFoundedLT (α i)] (hbot : ∀ ⦃i⦄ ⦃a : α i⦄, ¬a < 0) : WellFoundedLT (Π₀ i, α i) :=
  ⟨by
    set β := fun i ↦ Antisymmetrization (α i) (· ≤ ·)
    set e : (i : ι) → α i → β i := fun i ↦ toAntisymmetrization (· ≤ ·)
    let _ : ∀ i, Zero (β i) := fun i ↦ ⟨e i 0⟩
    have : WellFounded (Dfinsupp.Lex (Function.swap <| @WellOrderingRel ι)
      (fun _ ↦ (· < ·) : (i : ι) → β i → β i → Prop))
    · have := IsTrichotomous.swap (@WellOrderingRel ι)
      refine Lex.wellFounded' ?_ (fun i ↦ IsWellFounded.wf) ?_
      · rintro i ⟨a⟩
        apply hbot
      · simp only [Function.swap]
        exact IsWellFounded.wf
    refine Subrelation.wf (fun h => ?_) <| InvImage.wf (mapRange (fun i ↦ e i) fun _ ↦ rfl) this
    have := IsStrictOrder.swap (@WellOrderingRel ι)
    obtain ⟨i, he, hl⟩ := lex_lt_of_lt_of_preorder (Function.swap WellOrderingRel) h
    exact ⟨i, fun j hj ↦ Quot.sound (he j hj), hl⟩⟩
#align dfinsupp.well_founded_lt Dfinsupp.wellFoundedLT

instance Dfinsupp.well_founded_lt' [∀ i, CanonicallyOrderedAddMonoid (α i)]
    [∀ i, WellFoundedLT (α i)] : WellFoundedLT (Π₀ i, α i) :=
  Dfinsupp.wellFoundedLT fun _i a => (zero_le a).not_lt
#align dfinsupp.well_founded_lt' Dfinsupp.well_founded_lt'

instance Pi.wellFoundedLT [Finite ι] [∀ i, Preorder (α i)] [hw : ∀ i, WellFoundedLT (α i)] :
    WellFoundedLT (∀ i, α i) :=
  ⟨by
    obtain h | ⟨⟨x⟩⟩ := isEmpty_or_nonempty (∀ i, α i)
    · convert emptyWf.wf
    letI : ∀ i, Zero (α i) := fun i => ⟨(hw i).wf.min ⊤ ⟨x i, trivial⟩⟩
    haveI := Fintype.ofFinite ι
    refine' InvImage.wf equivFunOnFintype.symm (Dfinsupp.wellFoundedLT fun i a => _).wf
    exact (hw i).wf.not_lt_min ⊤ _ trivial⟩
#align pi.well_founded_lt Pi.wellFoundedLT

instance Function.wellFoundedLT {α} [Finite ι] [Preorder α] [WellFoundedLT α] :
    WellFoundedLT (ι → α) :=
  Pi.wellFoundedLT
#align function.well_founded_lt Function.wellFoundedLT

instance Dfinsupp.wellFoundedLT_of_finite [Finite ι] [∀ i, Zero (α i)] [∀ i, Preorder (α i)]
    [∀ i, WellFoundedLT (α i)] : WellFoundedLT (Π₀ i, α i) :=
  have := Fintype.ofFinite ι
  ⟨InvImage.wf equivFunOnFintype Pi.wellFoundedLT.wf⟩
#align dfinsupp.well_founded_lt_of_finite Dfinsupp.wellFoundedLT_of_finite


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

! This file was ported from Lean 3 source module analysis.fourier.riemann_lebesgue_lemma
! leanprover-community/mathlib commit 3353f3371120058977ce1e20bf7fc8986c0fb042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Function.ContinuousMapDense
import Mathbin.MeasureTheory.Integral.IntegralEqImproper
import Mathbin.MeasureTheory.Group.Integration
import Mathbin.Topology.ContinuousFunction.ZeroAtInfty
import Mathbin.Analysis.Fourier.FourierTransform

/-!
# The Riemann-Lebesgue Lemma

In this file we prove a weak form of the Riemann-Lebesgue lemma, stating that for any
compactly-supported continuous function `f` on `ℝ` (valued in some complete normed space `E`), the
integral

`∫ (x : ℝ), exp (↑(t * x) * I) • f x`

tends to zero as `t → ∞`. (The actual lemma is that this holds for all `L¹` functions `f`, which
follows from the result proved here together with the fact that continuous, compactly-supported
functions are dense in `L¹(ℝ)`, which will be proved in a future iteration.)

## Main results

- `tendsto_integral_mul_exp_at_top_of_continuous_compact_support`: the Riemann-Lebesgue lemma for
  continuous compactly-supported functions on `ℝ`.
-/

open MeasureTheory Filter Complex Set

open Filter Topology Real ENNReal

section ContinuousCompactSupport

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace ℂ E] {f : ℝ → E}

/-- The integrand in the Riemann-Lebesgue lemma is integrable. -/
theorem fourierIntegrandIntegrable (hf : Integrable f) (t : ℝ) :
    Integrable fun x : ℝ => exp (↑(t * x) * I) • f x :=
  by
  rw [← integrable_norm_iff]
  simp_rw [norm_smul, norm_exp_of_real_mul_I, one_mul]
  exacts[hf.norm, (Continuous.aeStronglyMeasurable (by continuity)).smul hf.1]
#align fourier_integrand_integrable fourierIntegrandIntegrable

variable [CompleteSpace E]

/-- Shifting `f` by `π / t` negates the integral in the Riemann-Lebesgue lemma. -/
theorem fourier_integral_half_period_translate {t : ℝ} (ht : t ≠ 0) :
    (∫ x : ℝ, exp (↑(t * x) * I) • f (x + π / t)) = -∫ x : ℝ, exp (↑(t * x) * I) • f x :=
  by
  have :
    (fun x : ℝ => exp (↑(t * x) * I) • f (x + π / t)) = fun x : ℝ =>
      (fun y : ℝ => -exp (↑(t * y) * I) • f y) (x + π / t) :=
    by
    ext1 x
    dsimp only
    rw [of_real_mul, of_real_mul, of_real_add, mul_add, add_mul, exp_add, ← neg_mul]
    replace ht := complex.of_real_ne_zero.mpr ht
    have : ↑t * ↑(π / t) * I = π * I := by
      field_simp
      ring
    rw [this, exp_pi_mul_I]
    ring_nf
  rw [this, integral_add_right_eq_self]
  simp_rw [neg_smul, integral_neg]
#align fourier_integral_half_period_translate fourier_integral_half_period_translate

/-- Rewrite the Riemann-Lebesgue integral in a form that allows us to use uniform continuity. -/
theorem fourier_integral_eq_half_sub_half_period_translate {t : ℝ} (ht : t ≠ 0)
    (hf : Integrable f) :
    (∫ x : ℝ, exp (↑(t * x) * I) • f x) =
      (1 / (2 : ℂ)) • ∫ x : ℝ, exp (↑(t * x) * I) • (f x - f (x + π / t)) :=
  by
  simp_rw [smul_sub]
  rw [integral_sub, fourier_integral_half_period_translate ht, sub_eq_add_neg, neg_neg, ←
    two_smul ℂ _, ← @smul_assoc _ _ _ _ _ _ (IsScalarTower.left ℂ), smul_eq_mul]
  norm_num
  exacts[fourierIntegrandIntegrable hf t, fourierIntegrandIntegrable (hf.comp_add_right (π / t)) t]
#align fourier_integral_eq_half_sub_half_period_translate fourier_integral_eq_half_sub_half_period_translate

/-- Riemann-Lebesgue Lemma for continuous and compactly-supported functions: the integral
`∫ x, exp (t * x * I) • f x` tends to 0 as `t` gets large.  -/
theorem tendsto_integral_mul_exp_atTop_of_continuous_compact_support (hf1 : Continuous f)
    (hf2 : HasCompactSupport f) :
    Tendsto (fun t : ℝ => ∫ x : ℝ, exp (↑(t * x) * I) • f x) atTop (𝓝 0) :=
  by
  simp_rw [NormedAddCommGroup.tendsto_nhds_zero, eventually_at_top, ge_iff_le]
  intro ε hε
  -- Extract an explicit candidate bound on `t` from uniform continuity.
  obtain ⟨R, hR1, hR2⟩ := hf2.exists_pos_le_norm
  obtain ⟨δ, hδ1, hδ2⟩ :=
    metric.uniform_continuous_iff.mp (hf2.uniform_continuous_of_continuous hf1) (ε / (1 + 2 * R))
      (div_pos hε (by positivity))
  refine' ⟨max π (1 + π / δ), fun t ht => _⟩
  have tpos : 0 < t := lt_of_lt_of_le Real.pi_pos ((le_max_left _ _).trans ht)
  -- Rewrite integral in terms of `f x - f (x + π / t)`.
  rw [fourier_integral_eq_half_sub_half_period_translate
      (lt_of_lt_of_le (lt_max_of_lt_left Real.pi_pos) ht).ne'
      (hf1.integrable_of_has_compact_support hf2)]
  rw [norm_smul, norm_eq_abs, ← Complex.ofReal_one, ← of_real_bit0, ← of_real_div,
    Complex.abs_of_nonneg one_half_pos.le]
  have : ε = 1 / 2 * (2 * ε) := by
    field_simp
    ring
  rw [this, mul_lt_mul_left (one_half_pos : (0 : ℝ) < 1 / 2)]
  have :
    ‖∫ x : ℝ, exp (↑(t * x) * I) • (f x - f (x + π / t))‖ ≤
      ∫ x : ℝ, ‖exp (↑(t * x) * I) • (f x - f (x + π / t))‖ :=
    norm_integral_le_integral_norm _
  refine' lt_of_le_of_lt this _
  simp_rw [norm_smul, norm_exp_of_real_mul_I, one_mul]
  -- Show integral can be taken over `[-(R + 1), R] ⊂ ℝ`.
  let A := Icc (-(R + 1)) R
  have int_Icc : (∫ x : ℝ, ‖f x - f (x + π / t)‖) = ∫ x in A, ‖f x - f (x + π / t)‖ :=
    by
    refine' (set_integral_eq_integral_of_forall_compl_eq_zero fun x hx => _).symm
    rw [mem_Icc, not_and_or, not_le, not_le, lt_neg] at hx
    suffices f x = 0 ∧ f (x + π / t) = 0 by rw [this.1, this.2, sub_zero, norm_zero]
    have tp : 0 < t := real.pi_pos.trans_le ((le_max_left _ _).trans ht)
    refine' ⟨hR2 x <| le_abs.mpr _, hR2 _ <| le_abs.mpr _⟩
    · cases hx
      · exact Or.inr ((le_add_of_nonneg_right zero_le_one).trans hx.le)
      · exact Or.inl hx.le
    · cases hx
      · refine' Or.inr _
        rw [neg_add, ← sub_eq_add_neg, le_sub_iff_add_le]
        refine' le_trans (add_le_add_left _ R) hx.le
        exact (div_le_one tp).mpr ((le_max_left _ _).trans ht)
      · exact Or.inl (hx.trans <| lt_add_of_pos_right _ <| div_pos Real.pi_pos tp).le
  rw [int_Icc]
  -- Bound integral using fact that ‖f x - f (x + π / t)‖ is small.
  have bdA : ∀ x : ℝ, x ∈ A → ‖‖f x - f (x + π / t)‖‖ ≤ ε / (1 + 2 * R) :=
    by
    simp_rw [norm_norm]
    refine' fun x _ => le_of_lt _
    simp_rw [dist_eq_norm] at hδ2
    apply hδ2
    rw [sub_add_cancel', Real.norm_eq_abs, abs_neg, abs_of_pos (div_pos Real.pi_pos tpos),
      div_lt_iff tpos, mul_comm, ← div_lt_iff hδ1]
    linarith [(le_max_right π (1 + π / δ)).trans ht]
  have bdA2 := norm_set_integral_le_of_norm_le_const (measure_Icc_lt_top : volume A < ∞) bdA _
  swap
  · apply Continuous.aeStronglyMeasurable
    exact
      continuous_norm.comp <|
        Continuous.sub hf1 <| Continuous.comp hf1 <| continuous_id'.add continuous_const
  have : ‖_‖ = ∫ x : ℝ in A, ‖f x - f (x + π / t)‖ :=
    Real.norm_of_nonneg (set_integral_nonneg measurableSet_Icc fun x hx => norm_nonneg _)
  rw [this] at bdA2
  refine' lt_of_le_of_lt bdA2 _
  rw [Real.volume_Icc, (by ring : R - -(R + 1) = 1 + 2 * R)]
  have hh : 0 < 1 + 2 * R := by positivity
  rw [ENNReal.toReal_ofReal hh.le, div_mul_cancel _ hh.ne', two_mul]
  exact lt_add_of_pos_left _ hε
#align tendsto_integral_mul_exp_at_top_of_continuous_compact_support tendsto_integral_mul_exp_atTop_of_continuous_compact_support

theorem tendsto_integral_mul_exp_atBot_of_continuous_compact_support (hf1 : Continuous f)
    (hf2 : HasCompactSupport f) :
    Tendsto (fun t : ℝ => ∫ x : ℝ, exp (↑(t * x) * I) • f x) atBot (𝓝 0) :=
  by
  have hg2 : HasCompactSupport (f ∘ Neg.neg) := by
    simpa only [neg_one_smul] using hf2.comp_smul (neg_ne_zero.mpr <| one_ne_zero' ℝ)
  convert(tendsto_integral_mul_exp_atTop_of_continuous_compact_support (hf1.comp continuous_neg)
          hg2).comp
      tendsto_neg_at_bot_at_top
  ext1 t
  simp_rw [Function.comp_apply, neg_mul, ← mul_neg]
  rw [← integral_neg_eq_self]
#align tendsto_integral_mul_exp_at_bot_of_continuous_compact_support tendsto_integral_mul_exp_atBot_of_continuous_compact_support

theorem zero_at_infty_integral_mul_exp_of_continuous_compact_support (hf1 : Continuous f)
    (hf2 : HasCompactSupport f) :
    Tendsto (fun t : ℝ => ∫ x : ℝ, exp (↑(t * x) * I) • f x) (cocompact ℝ) (𝓝 0) :=
  by
  rw [Real.cocompact_eq, tendsto_sup]
  exact
    ⟨tendsto_integral_mul_exp_atBot_of_continuous_compact_support hf1 hf2,
      tendsto_integral_mul_exp_atTop_of_continuous_compact_support hf1 hf2⟩
#align zero_at_infty_integral_mul_exp_of_continuous_compact_support zero_at_infty_integral_mul_exp_of_continuous_compact_support

open FourierTransform

/-- Riemann-Lebesgue lemma for continuous compactly-supported functions: the Fourier transform
tends to 0 at infinity. -/
theorem Real.fourierIntegral_zero_at_infty_of_continuous_compact_support (hc : Continuous f)
    (hs : HasCompactSupport f) : Tendsto (𝓕 f) (cocompact ℝ) (𝓝 0) :=
  by
  refine'
    ((zero_at_infty_integral_mul_exp_of_continuous_compact_support hc hs).comp
          (tendsto_cocompact_mul_left₀
            (mul_ne_zero (neg_ne_zero.mpr two_ne_zero) real.pi_pos.ne'))).congr
      fun w => _
  rw [Real.fourierIntegral_eq_integral_exp_smul, Function.comp_apply]
  congr 1 with x : 1
  ring_nf
#align real.fourier_integral_zero_at_infty_of_continuous_compact_support Real.fourierIntegral_zero_at_infty_of_continuous_compact_support

end ContinuousCompactSupport


import algebra.ring algebra.group_power
import tactic.ring

variables {A : Type*} [comm_ring A] (a b : A) (n m : ℕ)

namespace pow_add_split

def α : ℕ → ℕ → A → A → A
| 0 m a b := 0
| (n + 1) 0 a b := (a + b) ^ n
| (n + 1) (m + 1) a b := (α (n + 1) m a b) + (α n (m + 1) a b) * b

end pow_add_split

open pow_add_split

/-
 It looks like the induction needs to be generalised for this to work

lemma pow_add_split : ∀ (p n m : ℕ) (hp : p + 1 = n + m) (a b : A),
 (a + b) ^ p = (α m n a b) * a ^ n + (α n m b a) * b ^ m
| 0 0 0 hp a b := by {exfalso, exact nat.zero_ne_one hp.symm,}
| 0 0 1 _ a b := by {rw[α,α,zero_mul,add_zero,pow_zero,pow_zero,mul_one],}
| 0 1 0 _ a b := by {rw[α,α,zero_mul,zero_add,pow_zero,pow_zero,pow_zero,mul_one],}
| 0 (n + 1) (m + 1) hp a b := by {
   rw[zero_add,add_assoc,add_comm 1,add_assoc m,← add_assoc] at hp,
   cases hp,
  }
| (p + 1) 0 0 hp a b := by {cases hp}
| (p + 1) 0 (m + 1) hp a b := by {
    rw[zero_add] at hp,let hp' := nat.succ_inj hp,
    rw[α,α,hp',pow_zero,mul_one,zero_mul,add_zero],
  }
| (p + 1) (n + 1) 0 hp a b := by {
    rw[add_zero] at hp,let hp' := nat.succ_inj hp,
    rw[α,α,hp',pow_zero,mul_one,zero_mul,zero_add,add_comm],
  }
| (p + 1) (n + 1) (m + 1) hp a b := by {
    rw[add_assoc,add_assoc,add_comm 1 (m + 1),add_assoc,← add_assoc n m] at hp,
    let hp' : p = n + m := nat.succ_inj (nat.succ_inj hp),
    have hn : p + 1 = n + (m + 1) := by {rw[hp',add_assoc],},
    have hm : p + 1 = (n + 1) + m := by {rw[hp',add_assoc,add_assoc,add_comm 1],},
    let en := congr_arg (λ x, x * b) (pow_add_split p n (m + 1) hn a b),
    let em := congr_arg (λ x, x * a) (pow_add_split p (n + 1) m hm a b),
    simp only [] at en em,
    rw[α,α], repeat {rw[pow_add,pow_one]}, rw[mul_add,en,em], ring,
    sorry
}

-/


/-
Copyright (c) 2015 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Robert Y. Lewis
-/
import algebra.group_power.basic
import algebra.group_with_zero.commute
import algebra.hom.ring
import algebra.ring.commute
import algebra.group_with_zero.divisibility
import algebra.ring.divisibility
import data.nat.order.basic

/-!
# Power operations on monoids with zero, semirings, and rings

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

This file provides additional lemmas about the natural power operator on rings and semirings.
Further lemmas about ordered semirings and rings can be found in `algebra.group_power.lemmas`.

-/

variables {R S M : Type*}

section monoid_with_zero
variables [monoid_with_zero M]

lemma zero_pow : ∀ {n : ℕ}, 0 < n → (0 : M) ^ n = 0
| (n+1) _ := by rw [pow_succ, zero_mul]

@[simp] lemma zero_pow' : ∀ n : ℕ, n ≠ 0 → (0 : M) ^ n = 0
| 0     h := absurd rfl h
| (k+1) h := by { rw [pow_succ], exact zero_mul _ }

lemma zero_pow_eq (n : ℕ) : (0 : M)^n = if n = 0 then 1 else 0 :=
begin
  split_ifs with h,
  { rw [h, pow_zero], },
  { rw [zero_pow (nat.pos_of_ne_zero h)] },
end

lemma pow_eq_zero_of_le {x : M} {n m : ℕ}
  (hn : n ≤ m) (hx : x^n = 0) : x^m = 0 :=
by rw [← tsub_add_cancel_of_le hn, pow_add, hx, mul_zero]

theorem pow_eq_zero [no_zero_divisors M] {x : M} {n : ℕ} (H : x^n = 0) :
  x = 0 :=
begin
  induction n with n ih,
  { rw pow_zero at H,
    rw [← mul_one x, H, mul_zero] },
  { rw pow_succ at H,
    exact or.cases_on (mul_eq_zero.1 H) id ih }
end

@[simp] lemma pow_eq_zero_iff [no_zero_divisors M]
  {a : M} {n : ℕ} (hn : 0 < n) :
  a ^ n = 0 ↔ a = 0 :=
begin
  refine ⟨pow_eq_zero, _⟩,
  rintros rfl,
  exact zero_pow hn,
end

lemma pow_eq_zero_iff' [no_zero_divisors M] [nontrivial M]
  {a : M} {n : ℕ} :
  a ^ n = 0 ↔ a = 0 ∧ n ≠ 0 :=
by cases (zero_le n).eq_or_gt; simp [*, ne_of_gt]

lemma pow_ne_zero_iff [no_zero_divisors M] {a : M} {n : ℕ} (hn : 0 < n) :
  a ^ n ≠ 0 ↔ a ≠ 0 :=
(pow_eq_zero_iff hn).not

lemma ne_zero_pow {a : M} {n : ℕ} (hn : n ≠ 0) : a ^ n ≠ 0 → a ≠ 0 :=
by { contrapose!, rintro rfl, exact zero_pow' n hn }

@[field_simps] theorem pow_ne_zero [no_zero_divisors M]
  {a : M} (n : ℕ) (h : a ≠ 0) : a ^ n ≠ 0 :=
mt pow_eq_zero h

instance ne_zero.pow [no_zero_divisors M] {x : M} [ne_zero x] {n : ℕ} :
  ne_zero (x ^ n) := ⟨pow_ne_zero n ne_zero.out⟩

theorem sq_eq_zero_iff [no_zero_divisors M] {a : M} : a ^ 2 = 0 ↔ a = 0 :=
pow_eq_zero_iff two_pos

@[simp] lemma zero_pow_eq_zero [nontrivial M] {n : ℕ} : (0 : M) ^ n = 0 ↔ 0 < n :=
begin
  split; intro h,
  { rw [pos_iff_ne_zero], rintro rfl, simpa using h },
  { exact zero_pow' n h.ne.symm }
end

lemma ring.inverse_pow (r : M) : ∀ (n : ℕ), ring.inverse r ^ n = ring.inverse (r ^ n)
| 0 := by rw [pow_zero, pow_zero, ring.inverse_one]
| (n + 1) := by rw [pow_succ, pow_succ', ring.mul_inverse_rev' ((commute.refl r).pow_left n),
                    ring.inverse_pow]

end monoid_with_zero

section comm_monoid_with_zero
variables [comm_monoid_with_zero M] {n : ℕ} (hn : 0 < n)
include M hn

/-- We define `x ↦ x^n` (for positive `n : ℕ`) as a `monoid_with_zero_hom` -/
def pow_monoid_with_zero_hom : M →*₀ M :=
{ map_zero' := zero_pow hn,
  ..pow_monoid_hom n }

@[simp]
lemma coe_pow_monoid_with_zero_hom : (pow_monoid_with_zero_hom hn : M → M) = (^ n) := rfl

@[simp]
lemma pow_monoid_with_zero_hom_apply (a : M) : pow_monoid_with_zero_hom hn a = a ^ n := rfl

end comm_monoid_with_zero

lemma pow_dvd_pow_iff [cancel_comm_monoid_with_zero R]
  {x : R} {n m : ℕ} (h0 : x ≠ 0) (h1 : ¬ is_unit x) :
  x ^ n ∣ x ^ m ↔ n ≤ m :=
begin
  split,
  { intro h, rw [← not_lt], intro hmn, apply h1,
    have : x ^ m * x ∣ x ^ m * 1,
    { rw [← pow_succ', mul_one], exact (pow_dvd_pow _ (nat.succ_le_of_lt hmn)).trans h },
    rwa [mul_dvd_mul_iff_left, ← is_unit_iff_dvd_one] at this, apply pow_ne_zero m h0 },
  { apply pow_dvd_pow }
end

section semiring
variables [semiring R] [semiring S]

protected lemma ring_hom.map_pow (f : R →+* S) (a) :
  ∀ n : ℕ, f (a ^ n) = (f a) ^ n :=
map_pow f a

lemma min_pow_dvd_add {n m : ℕ} {a b c : R} (ha : c ^ n ∣ a) (hb : c ^ m ∣ b) :
  c ^ (min n m) ∣ a + b :=
begin
  replace ha := (pow_dvd_pow c (min_le_left n m)).trans ha,
  replace hb := (pow_dvd_pow c (min_le_right n m)).trans hb,
  exact dvd_add ha hb
end

end semiring

section comm_semiring
variables [comm_semiring R]

lemma add_sq (a b : R) : (a + b) ^ 2 = a ^ 2 + 2 * a * b + b ^ 2 :=
by simp only [sq, add_mul_self_eq]

lemma add_sq' (a b : R) : (a + b) ^ 2 = a ^ 2 + b ^ 2 + 2 * a * b :=
by rw [add_sq, add_assoc, add_comm _ (b ^ 2), add_assoc]

alias add_sq ← add_pow_two

end comm_semiring

section has_distrib_neg
variables [monoid R] [has_distrib_neg R]

variables (R)
theorem neg_one_pow_eq_or : ∀ n : ℕ, (-1 : R)^n = 1 ∨ (-1 : R)^n = -1
| 0     := or.inl (pow_zero _)
| (n+1) := (neg_one_pow_eq_or n).swap.imp
  (λ h, by rw [pow_succ, h, neg_one_mul, neg_neg])
  (λ h, by rw [pow_succ, h, mul_one])
variables {R}

theorem neg_pow (a : R) (n : ℕ) : (- a) ^ n = (-1) ^ n * a ^ n :=
(neg_one_mul a) ▸ (commute.neg_one_left a).mul_pow n

@[simp] theorem neg_pow_bit0 (a : R) (n : ℕ) : (- a) ^ (bit0 n) = a ^ (bit0 n) :=
by rw [pow_bit0', neg_mul_neg, pow_bit0']

@[simp] theorem neg_pow_bit1 (a : R) (n : ℕ) : (- a) ^ (bit1 n) = - a ^ (bit1 n) :=
by simp only [bit1, pow_succ, neg_pow_bit0, neg_mul_eq_neg_mul]

@[simp] lemma neg_sq (a : R) : (-a) ^ 2 = a ^ 2 := by simp [sq]
@[simp] lemma neg_one_sq : (-1 : R) ^ 2 = 1 := by rw [neg_sq, one_pow]

alias neg_sq ← neg_pow_two
alias neg_one_sq ← neg_one_pow_two

end has_distrib_neg

section ring
variables [ring R] {a b : R}

protected lemma commute.sq_sub_sq (h : commute a b) : a ^ 2 - b ^ 2 = (a + b) * (a - b) :=
by rw [sq, sq, h.mul_self_sub_mul_self_eq]

@[simp]
lemma neg_one_pow_mul_eq_zero_iff {n : ℕ} {r : R} : (-1)^n * r = 0 ↔ r = 0 :=
by rcases neg_one_pow_eq_or R n; simp [h]

@[simp]
lemma mul_neg_one_pow_eq_zero_iff {n : ℕ} {r : R} : r * (-1)^n = 0 ↔ r = 0 :=
by rcases neg_one_pow_eq_or R n; simp [h]

variables [no_zero_divisors R]

protected lemma commute.sq_eq_sq_iff_eq_or_eq_neg (h : commute a b) :
  a ^ 2 = b ^ 2 ↔ a = b ∨ a = -b :=
by rw [←sub_eq_zero, h.sq_sub_sq, mul_eq_zero, add_eq_zero_iff_eq_neg, sub_eq_zero, or_comm]

@[simp] lemma sq_eq_one_iff : a^2 = 1 ↔ a = 1 ∨ a = -1 :=
by rw [←(commute.one_right a).sq_eq_sq_iff_eq_or_eq_neg, one_pow]

lemma sq_ne_one_iff : a^2 ≠ 1 ↔ a ≠ 1 ∧ a ≠ -1 := sq_eq_one_iff.not.trans not_or_distrib

end ring

section comm_ring
variables [comm_ring R]

lemma sq_sub_sq (a b : R) : a ^ 2 - b ^ 2 = (a + b) * (a - b) := (commute.all a b).sq_sub_sq

alias sq_sub_sq ← pow_two_sub_pow_two

lemma sub_sq (a b : R) : (a - b) ^ 2 = a ^ 2 - 2 * a * b + b ^ 2 :=
by rw [sub_eq_add_neg, add_sq, neg_sq, mul_neg, ← sub_eq_add_neg]

alias sub_sq ← sub_pow_two

lemma sub_sq' (a b : R) : (a - b) ^ 2 = a ^ 2 + b ^ 2 - 2 * a * b :=
by rw [sub_eq_add_neg, add_sq', neg_sq, mul_neg, ← sub_eq_add_neg]

variables [no_zero_divisors R] {a b : R}

lemma sq_eq_sq_iff_eq_or_eq_neg : a ^ 2 = b ^ 2 ↔ a = b ∨ a = -b :=
(commute.all a b).sq_eq_sq_iff_eq_or_eq_neg

lemma eq_or_eq_neg_of_sq_eq_sq (a b : R) : a ^ 2 = b ^ 2 → a = b ∨ a = -b :=
sq_eq_sq_iff_eq_or_eq_neg.1

/- Copies of the above comm_ring lemmas for `units R`. -/
namespace units

protected lemma sq_eq_sq_iff_eq_or_eq_neg {a b : Rˣ} : a ^ 2 = b ^ 2 ↔ a = b ∨ a = -b :=
by simp_rw [ext_iff, coe_pow, sq_eq_sq_iff_eq_or_eq_neg, units.coe_neg]

protected lemma eq_or_eq_neg_of_sq_eq_sq (a b : Rˣ) (h : a ^ 2 = b ^ 2) : a = b ∨ a = -b :=
units.sq_eq_sq_iff_eq_or_eq_neg.1 h

end units

end comm_ring


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.int.cast.defs
import algebra.hom.equiv.basic
import algebra.group_with_zero.inj_surj

/-!
# `ulift` instances for groups and monoids

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

This file defines instances for group, monoid, semigroup and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We use `tactic.pi_instance_derive_field`, even though it wasn't intended for this purpose,
which seems to work fine.

We also provide `ulift.mul_equiv : ulift R ≃* R` (and its additive analogue).
-/

universes u v
variables {α : Type u} {β : Type*} {x y : ulift.{v} α}

namespace ulift

@[to_additive] instance has_one [has_one α] : has_one (ulift α) := ⟨⟨1⟩⟩
@[simp, to_additive] lemma one_down [has_one α] : (1 : ulift α).down = 1 := rfl

@[to_additive] instance has_mul [has_mul α] : has_mul (ulift α) := ⟨λ f g, ⟨f.down * g.down⟩⟩
@[simp, to_additive] lemma mul_down [has_mul α] : (x * y).down = x.down * y.down := rfl

@[to_additive] instance has_div [has_div α] : has_div (ulift α) := ⟨λ f g, ⟨f.down / g.down⟩⟩
@[simp, to_additive] lemma div_down [has_div α] : (x / y).down = x.down / y.down := rfl

@[to_additive] instance has_inv [has_inv α] : has_inv (ulift α) := ⟨λ f, ⟨f.down⁻¹⟩⟩
@[simp, to_additive] lemma inv_down [has_inv α] : x⁻¹.down = (x.down)⁻¹ := rfl

@[to_additive]
instance has_smul [has_smul α β] : has_smul α (ulift β) := ⟨λ n x, up (n • x.down)⟩
@[simp, to_additive]
lemma smul_down [has_smul α β] (a : α) (b : ulift.{v} β) : (a • b).down = a • b.down := rfl

@[to_additive has_smul, to_additive_reorder 1]
instance has_pow [has_pow α β] : has_pow (ulift α) β := ⟨λ x n, up (x.down ^ n)⟩
@[simp, to_additive smul_down, to_additive_reorder 1]
lemma pow_down [has_pow α β] (a : ulift.{v} α) (b : β) : (a ^ b).down = a.down ^ b := rfl

/--
The multiplicative equivalence between `ulift α` and `α`.
-/
@[to_additive "The additive equivalence between `ulift α` and `α`."]
def _root_.mul_equiv.ulift [has_mul α] : ulift α ≃* α :=
{ map_mul' := λ x y, rfl,
  .. equiv.ulift }

@[to_additive]
instance semigroup [semigroup α] : semigroup (ulift α) :=
mul_equiv.ulift.injective.semigroup _ $ λ x y, rfl

@[to_additive]
instance comm_semigroup [comm_semigroup α] : comm_semigroup (ulift α) :=
equiv.ulift.injective.comm_semigroup _ $ λ x y, rfl

@[to_additive]
instance mul_one_class [mul_one_class α] : mul_one_class (ulift α) :=
equiv.ulift.injective.mul_one_class _ rfl $ λ x y, rfl

instance mul_zero_one_class [mul_zero_one_class α] : mul_zero_one_class (ulift α) :=
equiv.ulift.injective.mul_zero_one_class _ rfl rfl $ λ x y, rfl

@[to_additive]
instance monoid [monoid α] : monoid (ulift α) :=
equiv.ulift.injective.monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

@[to_additive]
instance comm_monoid [comm_monoid α] : comm_monoid (ulift α) :=
equiv.ulift.injective.comm_monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

instance [has_nat_cast α] : has_nat_cast (ulift α) := ⟨λ n, up n⟩
instance [has_int_cast α] : has_int_cast (ulift α) := ⟨λ n, up n⟩

@[simp, norm_cast] lemma up_nat_cast [has_nat_cast α] (n : ℕ) : up (n : α) = n := rfl
@[simp, norm_cast] lemma up_int_cast [has_int_cast α] (n : ℤ) : up (n : α) = n := rfl
@[simp, norm_cast] lemma down_nat_cast [has_nat_cast α] (n : ℕ) : down (n : ulift α) = n := rfl
@[simp, norm_cast] lemma down_int_cast [has_int_cast α] (n : ℤ) : down (n : ulift α) = n := rfl

instance add_monoid_with_one [add_monoid_with_one α] : add_monoid_with_one (ulift α) :=
{ nat_cast_zero := congr_arg ulift.up nat.cast_zero,
  nat_cast_succ := λ n, congr_arg ulift.up (nat.cast_succ _),
  .. ulift.has_one, .. ulift.add_monoid, ..ulift.has_nat_cast }

instance add_comm_monoid_with_one [add_comm_monoid_with_one α] :
  add_comm_monoid_with_one (ulift α) :=
{ ..ulift.add_monoid_with_one, .. ulift.add_comm_monoid }

instance monoid_with_zero [monoid_with_zero α] : monoid_with_zero (ulift α) :=
equiv.ulift.injective.monoid_with_zero _ rfl rfl (λ _ _, rfl) (λ _ _, rfl)

instance comm_monoid_with_zero [comm_monoid_with_zero α] : comm_monoid_with_zero (ulift α) :=
equiv.ulift.injective.comm_monoid_with_zero _ rfl rfl (λ _ _, rfl) (λ _ _, rfl)

@[to_additive]
instance div_inv_monoid [div_inv_monoid α] : div_inv_monoid (ulift α) :=
equiv.ulift.injective.div_inv_monoid _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

@[to_additive]
instance group [group α] : group (ulift α) :=
equiv.ulift.injective.group _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

@[to_additive]
instance comm_group [comm_group α] : comm_group (ulift α) :=
equiv.ulift.injective.comm_group _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance add_group_with_one [add_group_with_one α] : add_group_with_one (ulift α) :=
{ int_cast := λ n, ⟨n⟩,
  int_cast_of_nat := λ n, congr_arg ulift.up (int.cast_of_nat _),
  int_cast_neg_succ_of_nat := λ n, congr_arg ulift.up (int.cast_neg_succ_of_nat _),
  .. ulift.add_monoid_with_one, .. ulift.add_group }

instance add_comm_group_with_one [add_comm_group_with_one α] : add_comm_group_with_one (ulift α) :=
{ ..ulift.add_group_with_one, .. ulift.add_comm_group }

instance group_with_zero [group_with_zero α] : group_with_zero (ulift α) :=
equiv.ulift.injective.group_with_zero _ rfl rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl)
  (λ _ _, rfl)

instance comm_group_with_zero [comm_group_with_zero α] : comm_group_with_zero (ulift α) :=
equiv.ulift.injective.comm_group_with_zero _ rfl rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl)

@[to_additive add_left_cancel_semigroup]
instance left_cancel_semigroup [left_cancel_semigroup α] :
  left_cancel_semigroup (ulift α) :=
equiv.ulift.injective.left_cancel_semigroup _ (λ _ _, rfl)

@[to_additive add_right_cancel_semigroup]
instance right_cancel_semigroup [right_cancel_semigroup α] :
  right_cancel_semigroup (ulift α) :=
equiv.ulift.injective.right_cancel_semigroup _ (λ _ _, rfl)

@[to_additive add_left_cancel_monoid]
instance left_cancel_monoid [left_cancel_monoid α] :
  left_cancel_monoid (ulift α) :=
equiv.ulift.injective.left_cancel_monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

@[to_additive add_right_cancel_monoid]
instance right_cancel_monoid [right_cancel_monoid α] :
  right_cancel_monoid (ulift α) :=
equiv.ulift.injective.right_cancel_monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

@[to_additive add_cancel_monoid]
instance cancel_monoid [cancel_monoid α] :
  cancel_monoid (ulift α) :=
equiv.ulift.injective.cancel_monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

@[to_additive add_cancel_comm_monoid]
instance cancel_comm_monoid [cancel_comm_monoid α] :
  cancel_comm_monoid (ulift α) :=
equiv.ulift.injective.cancel_comm_monoid _ rfl (λ _ _, rfl) (λ _ _, rfl)

instance nontrivial [nontrivial α] : nontrivial (ulift α) :=
equiv.ulift.symm.injective.nontrivial

-- TODO we don't do `ordered_cancel_comm_monoid` or `ordered_comm_group`
-- We'd need to add instances for `ulift` in `order.basic`.

end ulift


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Kevin Buzzard
-/
import data.rat
import data.fintype.card
import algebra.big_operators.nat_antidiagonal
import ring_theory.power_series.well_known

/-!
# Bernoulli numbers

The Bernoulli numbers are a sequence of rational numbers that frequently show up in
number theory.

## Mathematical overview

The Bernoulli numbers $(B_0, B_1, B_2, \ldots)=(1, -1/2, 1/6, 0, -1/30, \ldots)$ are
a sequence of rational numbers. They show up in the formula for the sums of $k$th
powers. They are related to the Taylor series expansions of $x/\tan(x)$ and
of $\coth(x)$, and also show up in the values that the Riemann Zeta function
takes both at both negative and positive integers (and hence in the
theory of modular forms). For example, if $1 \leq n$ is even then

$$\zeta(2n)=\sum_{t\geq1}t^{-2n}=(-1)^{n+1}\frac{(2\pi)^{2n}B_{2n}}{2(2n)!}.$$

Note however that this result is not yet formalised in Lean.

The Bernoulli numbers can be formally defined using the power series

$$\sum B_n\frac{t^n}{n!}=\frac{t}{1-e^{-t}}$$

although that happens to not be the definition in mathlib (this is an *implementation
detail* and need not concern the mathematician).

Note that $B_1=-1/2$, meaning that we are using the $B_n^-$ of
[from Wikipedia](https://en.wikipedia.org/wiki/Bernoulli_number).

## Implementation detail

The Bernoulli numbers are defined using well-founded induction, by the formula
$$B_n=1-\sum_{k\lt n}\frac{\binom{n}{k}}{n-k+1}B_k.$$
This formula is true for all $n$ and in particular $B_0=1$. Note that this is the definition
for positive Bernoulli numbers, which we call `bernoulli'`. The negative Bernoulli numbers are
then defined as `bernoulli := (-1)^n * bernoulli'`.

## Main theorems

`sum_bernoulli : ∑ k in finset.range n, (n.choose k : ℚ) * bernoulli k = 0`
-/

open_locale nat big_operators
open finset nat finset.nat power_series
variables (A : Type*) [comm_ring A] [algebra ℚ A]

/-! ### Definitions -/

/-- The Bernoulli numbers:
the $n$-th Bernoulli number $B_n$ is defined recursively via
$$B_n = 1 - \sum_{k < n} \binom{n}{k}\frac{B_k}{n+1-k}$$ -/
def bernoulli' : ℕ → ℚ :=
well_founded.fix lt_wf $
  λ n bernoulli', 1 - ∑ k : fin n, n.choose k / (n - k + 1) * bernoulli' k k.2

lemma bernoulli'_def' (n : ℕ) :
  bernoulli' n = 1 - ∑ k : fin n, n.choose k / (n - k + 1) * bernoulli' k :=
well_founded.fix_eq _ _ _

lemma bernoulli'_def (n : ℕ) :
  bernoulli' n = 1 - ∑ k in range n, n.choose k / (n - k + 1) * bernoulli' k :=
by { rw [bernoulli'_def', ← fin.sum_univ_eq_sum_range], refl }

lemma bernoulli'_spec (n : ℕ) :
  ∑ k in range n.succ, (n.choose (n - k) : ℚ) / (n - k + 1) * bernoulli' k = 1 :=
begin
  rw [sum_range_succ_comm, bernoulli'_def n, nat.sub_self],
  conv in (n.choose (_ - _)) { rw choose_symm (mem_range.1 H).le },
  simp only [one_mul, cast_one, sub_self, sub_add_cancel, choose_zero_right, zero_add, div_one],
end

lemma bernoulli'_spec' (n : ℕ) :
  ∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli' k.1 = 1 :=
begin
  refine ((sum_antidiagonal_eq_sum_range_succ_mk _ n).trans _).trans (bernoulli'_spec n),
  refine sum_congr rfl (λ x hx, _),
  simp only [nat.add_sub_cancel', mem_range_succ_iff.mp hx, cast_sub],
end

/-! ### Examples -/

section examples

@[simp] lemma bernoulli'_zero : bernoulli' 0 = 1 :=
by { rw bernoulli'_def, norm_num }

@[simp] lemma bernoulli'_one : bernoulli' 1 = 1/2 :=
by { rw bernoulli'_def, norm_num }

@[simp] lemma bernoulli'_two : bernoulli' 2 = 1/6 :=
by { rw bernoulli'_def, norm_num [sum_range_succ] }

@[simp] lemma bernoulli'_three : bernoulli' 3 = 0 :=
by { rw bernoulli'_def, norm_num [sum_range_succ] }

@[simp] lemma bernoulli'_four : bernoulli' 4 = -1/30 :=
have nat.choose 4 2 = 6 := dec_trivial, -- shrug
by { rw bernoulli'_def, norm_num [sum_range_succ, this] }

end examples

@[simp] lemma sum_bernoulli' (n : ℕ) :
  ∑ k in range n, (n.choose k : ℚ) * bernoulli' k = n :=
begin
  cases n, { simp },
  suffices : (n + 1 : ℚ) * ∑ k in range n, ↑(n.choose k) / (n - k + 1) * bernoulli' k =
    ∑ x in range n, ↑(n.succ.choose x) * bernoulli' x,
  { rw_mod_cast [sum_range_succ, bernoulli'_def, ← this, choose_succ_self_right], ring },
  simp_rw [mul_sum, ← mul_assoc],
  refine sum_congr rfl (λ k hk, _),
  congr',
  have : ((n - k : ℕ) : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero,
  field_simp [← cast_sub (mem_range.1 hk).le, mul_comm],
  rw_mod_cast [nat.sub_add_eq_add_sub (mem_range.1 hk).le, choose_mul_succ_eq],
end

/-- The exponential generating function for the Bernoulli numbers `bernoulli' n`. -/
def bernoulli'_power_series := mk $ λ n, algebra_map ℚ A (bernoulli' n / n!)

theorem bernoulli'_power_series_mul_exp_sub_one :
  bernoulli'_power_series A * (exp A - 1) = X * exp A :=
begin
  ext n,
  -- constant coefficient is a special case
  cases n, { simp },
  rw [bernoulli'_power_series, coeff_mul, mul_comm X, sum_antidiagonal_succ'],
  suffices : ∑ p in antidiagonal n, (bernoulli' p.1 / p.1!) * ((p.2 + 1) * p.2!)⁻¹ = n!⁻¹,
  { simpa [ring_hom.map_sum] using congr_arg (algebra_map ℚ A) this },
  apply eq_inv_of_mul_left_eq_one,
  rw sum_mul,
  convert bernoulli'_spec' n using 1,
  apply sum_congr rfl,
  simp_rw [mem_antidiagonal],
  rintro ⟨i, j⟩ rfl,
  have : (j + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero j,
  have : (j + 1 : ℚ) * j! * i! ≠ 0 := by simpa [factorial_ne_zero],
  have := factorial_mul_factorial_dvd_factorial_add i j,
  field_simp [mul_comm _ (bernoulli' i), mul_assoc, add_choose],
  rw_mod_cast [mul_comm (j + 1), mul_div_assoc, ← mul_assoc],
  rw [cast_mul, cast_mul, mul_div_mul_right, cast_dvd_char_zero, cast_mul],
  assumption',
end

/-- Odd Bernoulli numbers (greater than 1) are zero. -/
theorem bernoulli'_odd_eq_zero {n : ℕ} (h_odd : odd n) (hlt : 1 < n) : bernoulli' n = 0 :=
begin
  let B := mk (λ n, bernoulli' n / n!),
  suffices : (B - eval_neg_hom B) * (exp ℚ - 1) = X * (exp ℚ - 1),
  { cases mul_eq_mul_right_iff.mp this;
    simp only [power_series.ext_iff, eval_neg_hom, coeff_X] at h,
    { apply eq_zero_of_neg_eq,
      specialize h n,
      split_ifs at h;
      simp [neg_one_pow_of_odd h_odd, factorial_ne_zero, *] at * },
    { simpa using h 1 } },
  have h : B * (exp ℚ - 1) = X * exp ℚ,
  { simpa [bernoulli'_power_series] using bernoulli'_power_series_mul_exp_sub_one ℚ },
  rw [sub_mul, h, mul_sub X, sub_right_inj, ← neg_sub, ← neg_mul_eq_mul_neg, neg_eq_iff_neg_eq],
  suffices : eval_neg_hom (B * (exp ℚ - 1)) * exp ℚ = eval_neg_hom (X * exp ℚ) * exp ℚ,
  { simpa [mul_assoc, sub_mul, mul_comm (eval_neg_hom (exp ℚ)), exp_mul_exp_neg_eq_one, eq_comm] },
  congr',
end

/-- The Bernoulli numbers are defined to be `bernoulli'` with a parity sign. -/
def bernoulli (n : ℕ) : ℚ := (-1)^n * bernoulli' n

lemma bernoulli'_eq_bernoulli (n : ℕ) : bernoulli' n = (-1)^n * bernoulli n :=
by simp [bernoulli, ← mul_assoc, ← sq, ← pow_mul, mul_comm n 2, pow_mul]

@[simp] lemma bernoulli_zero : bernoulli 0 = 1 := by simp [bernoulli]

@[simp] lemma bernoulli_one : bernoulli 1 = -1/2 :=
by norm_num [bernoulli]

theorem bernoulli_eq_bernoulli'_of_ne_one {n : ℕ} (hn : n ≠ 1) : bernoulli n = bernoulli' n :=
begin
  by_cases h0 : n = 0, { simp [h0] },
  rw [bernoulli, neg_one_pow_eq_pow_mod_two],
  cases mod_two_eq_zero_or_one n, { simp [h] },
  simp [bernoulli'_odd_eq_zero (odd_iff.mpr h) (one_lt_iff_ne_zero_and_ne_one.mpr ⟨h0, hn⟩)],
end

@[simp] theorem sum_bernoulli (n : ℕ):
  ∑ k in range n, (n.choose k : ℚ) * bernoulli k = if n = 1 then 1 else 0 :=
begin
  cases n, { simp },
  cases n, { simp },
  suffices : ∑ i in range n, ↑((n + 2).choose (i + 2)) * bernoulli (i + 2) = n / 2,
  { simp only [this, sum_range_succ', cast_succ, bernoulli_one, bernoulli_zero, choose_one_right,
    mul_one, choose_zero_right, cast_zero, if_false, zero_add, succ_succ_ne_one], ring },
  have f := sum_bernoulli' n.succ.succ,
  simp_rw [sum_range_succ', bernoulli'_one, choose_one_right, cast_succ, ← eq_sub_iff_add_eq] at f,
  convert f,
  { ext x, rw bernoulli_eq_bernoulli'_of_ne_one (succ_ne_zero x ∘ succ.inj) },
  { simp only [one_div, mul_one, bernoulli'_zero, cast_one, choose_zero_right, add_sub_cancel],
    ring },
end

lemma bernoulli_spec' (n : ℕ) :
  ∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli k.1 =
    if n = 0 then 1 else 0 :=
begin
  cases n, { simp },
  rw if_neg (succ_ne_zero _),
  -- algebra facts
  have h₁ : (1, n) ∈ antidiagonal n.succ := by simp [mem_antidiagonal, add_comm],
  have h₂ : (n : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero,
  have h₃ : (1 + n).choose n = n + 1 := by simp [add_comm],
  -- key equation: the corresponding fact for `bernoulli'`
  have H := bernoulli'_spec' n.succ,
  -- massage it to match the structure of the goal, then convert piece by piece
  rw sum_eq_add_sum_diff_singleton h₁ at H ⊢,
  apply add_eq_of_eq_sub',
  convert eq_sub_of_add_eq' H using 1,
  { refine sum_congr rfl (λ p h, _),
    obtain ⟨h', h''⟩ : p ∈ _ ∧ p ≠ _ := by rwa [mem_sdiff, mem_singleton] at h,
    simp [bernoulli_eq_bernoulli'_of_ne_one ((not_congr (antidiagonal_congr h' h₁)).mp h'')] },
  { field_simp [h₃],
    norm_num },
end

/-- The exponential generating function for the Bernoulli numbers `bernoulli n`. -/
def bernoulli_power_series := mk $ λ n, algebra_map ℚ A (bernoulli n / n!)

theorem bernoulli_power_series_mul_exp_sub_one :
  bernoulli_power_series A * (exp A - 1) = X :=
begin
  ext n,
  -- constant coefficient is a special case
  cases n, { simp },
  simp only [bernoulli_power_series, coeff_mul, coeff_X, sum_antidiagonal_succ', one_div, coeff_mk,
    coeff_one, coeff_exp, linear_map.map_sub, factorial, if_pos, cast_succ, cast_one, cast_mul,
    sub_zero, ring_hom.map_one, add_eq_zero_iff, if_false, inv_one, zero_add, one_ne_zero, mul_zero,
    and_false, sub_self, ← ring_hom.map_mul, ← ring_hom.map_sum],
  suffices : ∑ x in antidiagonal n, bernoulli x.1 / x.1! * ((x.2 + 1) * x.2!)⁻¹
           = if n.succ = 1 then 1 else 0, { split_ifs; simp [h, this] },
  cases n, { simp },
  have hfact : ∀ m, (m! : ℚ) ≠ 0 := λ m, by exact_mod_cast factorial_ne_zero m,
  have hite1 : ite (n.succ.succ = 1) 1 0 = (0 / n.succ! : ℚ) := by simp,
  have hite2 : ite (n.succ = 0) 1 0 = (0 : ℚ) := by simp [succ_ne_zero],
  rw [hite1, eq_div_iff (hfact n.succ), ← hite2, ← bernoulli_spec', sum_mul],
  apply sum_congr rfl,
  rintro ⟨i, j⟩ h,
  rw mem_antidiagonal at h,
  have hj : (j.succ : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero j,
  field_simp [← h, mul_ne_zero hj (hfact j), hfact i, mul_comm _ (bernoulli i), mul_assoc],
  rw_mod_cast [mul_comm (j + 1), mul_div_assoc, ← mul_assoc],
  rw [cast_mul, cast_mul, mul_div_mul_right _ _ hj, add_choose, cast_dvd_char_zero],
  apply factorial_mul_factorial_dvd_factorial_add,
end

section faulhaber

/-- Faulhaber's theorem relating the sum of of p-th powers to the Bernoulli numbers.
See https://proofwiki.org/wiki/Faulhaber%27s_Formula and [orosi2018faulhaber] for
the proof provided here. -/
theorem sum_range_pow (n p : ℕ) :
  ∑ k in range n, (k : ℚ) ^ p =
    ∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
begin
  have hne : ∀ m : ℕ, (m! : ℚ) ≠ 0 := λ m, by exact_mod_cast factorial_ne_zero m,
  -- compute the Cauchy product of two power series
  have h_cauchy : mk (λ p, bernoulli p / p!) * mk (λ q, coeff ℚ (q + 1) (exp ℚ ^ n))
                = mk (λ p, ∑ i in range (p + 1),
                      bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!),
  { ext q,
    let f := λ a b, bernoulli a / a! * coeff ℚ (b + 1) (exp ℚ ^ n),
    -- key step: use `power_series.coeff_mul` and then rewrite sums
    simp only [coeff_mul, coeff_mk, cast_mul, sum_antidiagonal_eq_sum_range_succ f],
    apply sum_congr rfl,
    simp_intros m h only [finset.mem_range],
    simp only [f, exp_pow_eq_rescale_exp, rescale, one_div, coeff_mk, ring_hom.coe_mk, coeff_exp,
              ring_hom.id_apply, cast_mul, rat.algebra_map_rat_rat],
    -- manipulate factorials and binomial coefficients
    rw [choose_eq_factorial_div_factorial h.le, eq_comm, div_eq_iff (hne q.succ), succ_eq_add_one,
        mul_assoc _ _ ↑q.succ!, mul_comm _ ↑q.succ!, ← mul_assoc, div_mul_eq_mul_div,
        mul_comm (↑n ^ (q - m + 1)), ← mul_assoc _ _ (↑n ^ (q - m + 1)), ← one_div, mul_one_div,
        div_div_eq_div_mul, ← nat.sub_add_comm (le_of_lt_succ h), cast_dvd, cast_mul],
    { ring },
    { exact factorial_mul_factorial_dvd_factorial h.le },
    { simp [hne] } },
  -- same as our goal except we pull out `p!` for convenience
  have hps : ∑ k in range n, ↑k ^ p
          = (∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!)
            * p!,
  { suffices : mk (λ p, ∑ k in range n, ↑k ^ p * algebra_map ℚ ℚ p!⁻¹)
             = mk (λ p, ∑ i in range (p + 1),
                    bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!),
    { rw [← div_eq_iff (hne p), div_eq_mul_inv, sum_mul],
      rw power_series.ext_iff at this,
      simpa using this p },
    -- the power series `exp ℚ - 1` is non-zero, a fact we need in order to use `mul_right_inj'`
    have hexp : exp ℚ - 1 ≠ 0,
    { simp only [exp, power_series.ext_iff, ne, not_forall],
      use 1,
      simp },
    have h_r : exp ℚ ^ n - 1 = X * mk (λ p, coeff ℚ (p + 1) (exp ℚ ^ n)),
    { have h_const : C ℚ (constant_coeff ℚ (exp ℚ ^ n)) = 1 := by simp,
      rw [← h_const, sub_const_eq_X_mul_shift] },
    -- key step: a chain of equalities of power series
    rw [← mul_right_inj' hexp, mul_comm, ← exp_pow_sum, ← geom_sum_def, geom_sum_mul, h_r,
        ← bernoulli_power_series_mul_exp_sub_one, bernoulli_power_series, mul_right_comm],
    simp [h_cauchy, mul_comm] },
  -- massage `hps` into our goal
  rw [hps, sum_mul],
  refine sum_congr rfl (λ x hx, _),
  field_simp [mul_right_comm _ ↑p!, ← mul_assoc _ _ ↑p!, cast_add_one_ne_zero, hne],
end

/-- Alternate form of Faulhaber's theorem, relating the sum of p-th powers to the Bernoulli numbers.
Deduced from `sum_range_pow`. -/
theorem sum_range_pow' (n p : ℕ) :
  ∑ k in Ico 1 (n + 1), (k : ℚ) ^ p =
    ∑ i in range (p + 1), bernoulli' i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
begin
  -- dispose of the trivial case
  cases p, { simp },
  let f := λ i, bernoulli i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ,
  let f' := λ i, bernoulli' i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ,
  suffices : ∑ k in Ico 1 n.succ, ↑k ^ p.succ = ∑ i in range p.succ.succ, f' i, { convert this },
  -- prove some algebraic facts that will make things easier for us later on
  have hle := le_add_left 1 n,
  have hne : (p + 1 + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero p.succ,
  have h1 : ∀ r : ℚ, r * (p + 1 + 1) * n ^ p.succ / (p + 1 + 1 : ℚ) = r * n ^ p.succ :=
    λ r, by rw [mul_div_right_comm, mul_div_cancel _ hne],
  have h2 : f 1 + n ^ p.succ = 1 / 2 * n ^ p.succ,
  { simp_rw [f, bernoulli_one, choose_one_right, succ_sub_succ_eq_sub, cast_succ, nat.sub_zero, h1],
    ring },
  have : ∑ i in range p, bernoulli (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2)
       = ∑ i in range p, bernoulli' (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2) :=
    sum_congr rfl (λ i h, by rw bernoulli_eq_bernoulli'_of_ne_one (succ_succ_ne_one i)),
  calc  ∑ k in Ico 1 n.succ, ↑k ^ p.succ
        -- replace sum over `Ico` with sum over `range` and simplify
      = ∑ k in range n.succ, ↑k ^ p.succ : by simp [sum_Ico_eq_sub _ hle, succ_ne_zero]
        -- extract the last term of the sum
  ... = ∑ k in range n, (k : ℚ) ^ p.succ + n ^ p.succ : by rw sum_range_succ
        -- apply the key lemma, `sum_range_pow`
  ... = ∑ i in range p.succ.succ, f i + n ^ p.succ : by simp [f, sum_range_pow]
        -- extract the first two terms of the sum
  ... = ∑ i in range p, f i.succ.succ + f 1 + f 0 + n ^ p.succ : by simp_rw [sum_range_succ']
  ... = ∑ i in range p, f i.succ.succ + (f 1 + n ^ p.succ) + f 0 : by ring
  ... = ∑ i in range p, f i.succ.succ + 1 / 2 * n ^ p.succ + f 0 : by rw h2
        -- convert from `bernoulli` to `bernoulli'`
  ... = ∑ i in range p, f' i.succ.succ + f' 1 + f' 0 : by { simp only [f, f'], simpa [h1] }
        -- rejoin the first two terms of the sum
  ... = ∑ i in range p.succ.succ, f' i : by simp_rw [sum_range_succ'],
end

end faulhaber


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import algebra.module.basic
import group_theory.group_action.units
import data.int.cast
import algebra.order.absolute_value

/-!
# Absolute values and the integers

This file contains some results on absolute values applied to integers.

## Main results

 * `absolute_value.map_units_int`: an absolute value sends all units of `ℤ` to `1`
-/

variables {R S : Type*} [ring R] [linear_ordered_comm_ring S]

@[simp]
lemma absolute_value.map_units_int (abv : absolute_value ℤ S) (x : ℤˣ) :
  abv x = 1 :=
by rcases int.units_eq_one_or x with (rfl | rfl); simp

@[simp]
lemma absolute_value.map_units_int_cast [nontrivial R] (abv : absolute_value R S) (x : ℤˣ) :
  abv ((x : ℤ) : R) = 1 :=
by rcases int.units_eq_one_or x with (rfl | rfl); simp

@[simp]
lemma absolute_value.map_units_int_smul (abv : absolute_value R S) (x : ℤˣ) (y : R) :
  abv (x • y) = abv y :=
by rcases int.units_eq_one_or x with (rfl | rfl); simp