/-
Copyright (c) 2020 Alexander Bentkamp, Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp, Sébastien Gouëzel, Eric Wieser
-/
import linear_algebra.orientation
import algebra.order.smul
import data.complex.basic
import data.fin.vec_notation
import field_theory.tower
import algebra.char_p.invertible

/-!
# Complex number as a vector space over `ℝ`

This file contains the following instances:
* Any `•`-structure (`has_smul`, `mul_action`, `distrib_mul_action`, `module`, `algebra`) on
  `ℝ` imbues a corresponding structure on `ℂ`. This includes the statement that `ℂ` is an `ℝ`
  algebra.
* any complex vector space is a real vector space;
* any finite dimensional complex vector space is a finite dimensional real vector space;
* the space of `ℝ`-linear maps from a real vector space to a complex vector space is a complex
  vector space.

It also defines bundled versions of four standard maps (respectively, the real part, the imaginary
part, the embedding of `ℝ` in `ℂ`, and the complex conjugate):

* `complex.re_lm` (`ℝ`-linear map);
* `complex.im_lm` (`ℝ`-linear map);
* `complex.of_real_am` (`ℝ`-algebra (homo)morphism);
* `complex.conj_ae` (`ℝ`-algebra equivalence).

It also provides a universal property of the complex numbers `complex.lift`, which constructs a
`ℂ →ₐ[ℝ] A` into any `ℝ`-algebra `A` given a square root of `-1`.

In addition, this file provides a decomposition into `real_part` and `imaginary_part` for any
element of a `star_module` over `ℂ`.

## Notation

* `ℜ` and `ℑ` for the `real_part` and `imaginary_part`, respectively, in the locale
  `complex_star_module`.
-/

namespace complex

open_locale complex_conjugate

variables {R : Type*} {S : Type*}

section

variables [has_smul R ℝ]

/- The useless `0` multiplication in `smul` is to make sure that
`restrict_scalars.module ℝ ℂ ℂ = complex.module` definitionally. -/
instance : has_smul R ℂ :=
{ smul := λ r x, ⟨r • x.re - 0 * x.im, r • x.im + 0 * x.re⟩ }

lemma smul_re (r : R) (z : ℂ) : (r • z).re = r • z.re := by simp [(•)]
lemma smul_im (r : R) (z : ℂ) : (r • z).im = r • z.im := by simp [(•)]

@[simp] lemma real_smul {x : ℝ} {z : ℂ} : x • z = x * z := rfl

end

instance [has_smul R ℝ] [has_smul S ℝ] [smul_comm_class R S ℝ] : smul_comm_class R S ℂ :=
{ smul_comm := λ r s x, by ext; simp [smul_re, smul_im, smul_comm] }

instance [has_smul R S] [has_smul R ℝ] [has_smul S ℝ] [is_scalar_tower R S ℝ] :
  is_scalar_tower R S ℂ :=
{ smul_assoc := λ r s x, by ext; simp [smul_re, smul_im, smul_assoc] }

instance [has_smul R ℝ] [has_smul Rᵐᵒᵖ ℝ] [is_central_scalar R ℝ] :
  is_central_scalar R ℂ :=
{ op_smul_eq_smul := λ r x, by ext; simp [smul_re, smul_im, op_smul_eq_smul] }

instance [monoid R] [mul_action R ℝ] : mul_action R ℂ :=
{ one_smul := λ x, by ext; simp [smul_re, smul_im, one_smul],
  mul_smul := λ r s x, by ext; simp [smul_re, smul_im, mul_smul] }

instance [distrib_smul R ℝ] : distrib_smul R ℂ :=
{ smul_add := λ r x y, by ext; simp [smul_re, smul_im, smul_add],
  smul_zero := λ r, by ext; simp [smul_re, smul_im, smul_zero] }

instance [semiring R] [distrib_mul_action R ℝ] : distrib_mul_action R ℂ :=
{ ..complex.distrib_smul }

instance [semiring R] [module R ℝ] : module R ℂ :=
{ add_smul := λ r s x, by ext; simp [smul_re, smul_im, add_smul],
  zero_smul := λ r, by ext; simp [smul_re, smul_im, zero_smul] }

instance [comm_semiring R] [algebra R ℝ] : algebra R ℂ :=
{ smul := (•),
  smul_def' := λ r x, by ext; simp [smul_re, smul_im, algebra.smul_def],
  commutes' := λ r ⟨xr, xi⟩, by ext; simp [smul_re, smul_im, algebra.commutes],
  ..complex.of_real.comp (algebra_map R ℝ) }

instance : star_module ℝ ℂ :=
⟨λ r x, by simp only [star_def, star_trivial, real_smul, map_mul, conj_of_real]⟩

@[simp] lemma coe_algebra_map : (algebra_map ℝ ℂ : ℝ → ℂ) = coe := rfl

section
variables {A : Type*} [semiring A] [algebra ℝ A]

/-- We need this lemma since `complex.coe_algebra_map` diverts the simp-normal form away from
`alg_hom.commutes`. -/
@[simp] lemma _root_.alg_hom.map_coe_real_complex (f : ℂ →ₐ[ℝ] A) (x : ℝ) :
  f x = algebra_map ℝ A x :=
f.commutes x

/-- Two `ℝ`-algebra homomorphisms from ℂ are equal if they agree on `complex.I`. -/
@[ext]
lemma alg_hom_ext ⦃f g : ℂ →ₐ[ℝ] A⦄ (h : f I = g I) : f = g :=
begin
  ext ⟨x, y⟩,
  simp only [mk_eq_add_mul_I, alg_hom.map_add, alg_hom.map_coe_real_complex, alg_hom.map_mul, h]
end

end

section
open_locale complex_order

protected lemma ordered_smul : ordered_smul ℝ ℂ :=
ordered_smul.mk' $ λ a b r hab hr, ⟨by simp [hr, hab.1.le], by simp [hab.2]⟩

localized "attribute [instance] complex.ordered_smul" in complex_order

end

open submodule finite_dimensional

/-- `ℂ` has a basis over `ℝ` given by `1` and `I`. -/
noncomputable def basis_one_I : basis (fin 2) ℝ ℂ :=
basis.of_equiv_fun
{ to_fun := λ z, ![z.re, z.im],
  inv_fun := λ c, c 0 + c 1 • I,
  left_inv := λ z, by simp,
  right_inv := λ c, by { ext i, fin_cases i; simp },
  map_add' := λ z z', by simp,
  -- why does `simp` not know how to apply `smul_cons`, which is a `@[simp]` lemma, here?
  map_smul' := λ c z, by simp [matrix.smul_cons c z.re, matrix.smul_cons c z.im] }

@[simp] lemma coe_basis_one_I_repr (z : ℂ) : ⇑(basis_one_I.repr z) = ![z.re, z.im] := rfl

@[simp] lemma coe_basis_one_I : ⇑basis_one_I = ![1, I] :=
funext $ λ i, basis.apply_eq_iff.mpr $ finsupp.ext $ λ j,
by fin_cases i; fin_cases j;
    simp only [coe_basis_one_I_repr, finsupp.single_eq_of_ne, matrix.cons_val_zero,
      matrix.cons_val_one, matrix.head_cons, fin.one_eq_zero_iff, ne.def, not_false_iff, I_re,
      nat.succ_succ_ne_one, one_im, I_im, one_re, finsupp.single_eq_same, fin.zero_eq_one_iff]

instance : finite_dimensional ℝ ℂ := of_fintype_basis basis_one_I

@[simp] lemma finrank_real_complex : finite_dimensional.finrank ℝ ℂ = 2 :=
by rw [finrank_eq_card_basis basis_one_I, fintype.card_fin]

@[simp] lemma dim_real_complex : module.rank ℝ ℂ = 2 :=
by simp [← finrank_eq_dim, finrank_real_complex]

lemma {u} dim_real_complex' : cardinal.lift.{u} (module.rank ℝ ℂ) = 2 :=
by simp [← finrank_eq_dim, finrank_real_complex, bit0]

/-- `fact` version of the dimension of `ℂ` over `ℝ`, locally useful in the definition of the
circle. -/
lemma finrank_real_complex_fact : fact (finrank ℝ ℂ = 2) := ⟨finrank_real_complex⟩

/-- The standard orientation on `ℂ`. -/
protected noncomputable def orientation : orientation ℝ ℂ (fin 2) := complex.basis_one_I.orientation

end complex

/- Register as an instance (with low priority) the fact that a complex vector space is also a real
vector space. -/
@[priority 900]
instance module.complex_to_real (E : Type*) [add_comm_group E] [module ℂ E] : module ℝ E :=
restrict_scalars.module ℝ ℂ E

instance module.real_complex_tower (E : Type*) [add_comm_group E] [module ℂ E] :
  is_scalar_tower ℝ ℂ E :=
restrict_scalars.is_scalar_tower ℝ ℂ E

@[simp, norm_cast] lemma complex.coe_smul {E : Type*} [add_comm_group E] [module ℂ E]
  (x : ℝ) (y : E) :
  (x : ℂ) • y = x • y :=
rfl

/-- The scalar action of `ℝ` on a `ℂ`-module `E` induced by `module.complex_to_real` commutes with
another scalar action of `M` on `E` whenever the action of `ℂ` commutes with the action of `M`. -/
@[priority 900]
instance smul_comm_class.complex_to_real {M E : Type*}
  [add_comm_group E] [module ℂ E] [has_smul M E] [smul_comm_class ℂ M E] : smul_comm_class ℝ M E :=
{ smul_comm := λ r _ _, (smul_comm (r : ℂ) _ _ : _) }

@[priority 100]
instance finite_dimensional.complex_to_real (E : Type*) [add_comm_group E] [module ℂ E]
  [finite_dimensional ℂ E] : finite_dimensional ℝ E :=
finite_dimensional.trans ℝ ℂ E

lemma dim_real_of_complex (E : Type*) [add_comm_group E] [module ℂ E] :
  module.rank ℝ E = 2 * module.rank ℂ E :=
cardinal.lift_inj.1 $
  by { rw [← dim_mul_dim' ℝ ℂ E, complex.dim_real_complex], simp [bit0] }

lemma finrank_real_of_complex (E : Type*) [add_comm_group E] [module ℂ E] :
  finite_dimensional.finrank ℝ E = 2 * finite_dimensional.finrank ℂ E :=
by rw [← finite_dimensional.finrank_mul_finrank ℝ ℂ E, complex.finrank_real_complex]

@[priority 900]
instance star_module.complex_to_real {E : Type*} [add_comm_group E] [has_star E] [module ℂ E]
  [star_module ℂ E] : star_module ℝ E :=
⟨λ r a, by rw [←smul_one_smul ℂ r a, star_smul, star_smul, star_one, smul_one_smul]⟩

namespace complex

open_locale complex_conjugate

/-- Linear map version of the real part function, from `ℂ` to `ℝ`. -/
def re_lm : ℂ →ₗ[ℝ] ℝ :=
{ to_fun := λx, x.re,
  map_add' := add_re,
  map_smul' := by simp, }

@[simp] lemma re_lm_coe : ⇑re_lm = re := rfl

/-- Linear map version of the imaginary part function, from `ℂ` to `ℝ`. -/
def im_lm : ℂ →ₗ[ℝ] ℝ :=
{ to_fun := λx, x.im,
  map_add' := add_im,
  map_smul' := by simp, }

@[simp] lemma im_lm_coe : ⇑im_lm = im := rfl

/-- `ℝ`-algebra morphism version of the canonical embedding of `ℝ` in `ℂ`. -/
def of_real_am : ℝ →ₐ[ℝ] ℂ := algebra.of_id ℝ ℂ

@[simp] lemma of_real_am_coe : ⇑of_real_am = coe := rfl

/-- `ℝ`-algebra isomorphism version of the complex conjugation function from `ℂ` to `ℂ` -/
def conj_ae : ℂ ≃ₐ[ℝ] ℂ :=
{ inv_fun := conj,
  left_inv := star_star,
  right_inv := star_star,
  commutes' := conj_of_real,
  .. conj }

@[simp] lemma conj_ae_coe : ⇑conj_ae = conj := rfl

/-- The matrix representation of `conj_ae`. -/
@[simp] lemma to_matrix_conj_ae :
  linear_map.to_matrix basis_one_I basis_one_I conj_ae.to_linear_map = !![1, 0; 0, -1] :=
begin
  ext i j,
  simp [linear_map.to_matrix_apply],
  fin_cases i; fin_cases j; simp
end

/-- The identity and the complex conjugation are the only two `ℝ`-algebra homomorphisms of `ℂ`. -/
lemma real_alg_hom_eq_id_or_conj (f : ℂ →ₐ[ℝ] ℂ) : f = alg_hom.id ℝ ℂ ∨ f = conj_ae :=
begin
  refine (eq_or_eq_neg_of_sq_eq_sq (f I) I $ by rw [← map_pow, I_sq, map_neg, map_one]).imp _ _;
    refine λ h, alg_hom_ext _,
  exacts [h, conj_I.symm ▸ h],
end

/-- The natural `add_equiv` from `ℂ` to `ℝ × ℝ`. -/
@[simps apply symm_apply_re symm_apply_im { simp_rhs := tt }]
def equiv_real_prod_add_hom : ℂ ≃+ ℝ × ℝ :=
{ map_add' := by simp, .. equiv_real_prod }

/-- The natural `linear_equiv` from `ℂ` to `ℝ × ℝ`. -/
@[simps apply symm_apply_re symm_apply_im { simp_rhs := tt }]
def equiv_real_prod_lm : ℂ ≃ₗ[ℝ] ℝ × ℝ :=
{ map_smul' := by simp [equiv_real_prod_add_hom], .. equiv_real_prod_add_hom }

section lift

variables {A : Type*} [ring A] [algebra ℝ A]

/-- There is an alg_hom from `ℂ` to any `ℝ`-algebra with an element that squares to `-1`.

See `complex.lift` for this as an equiv. -/
def lift_aux (I' : A) (hf : I' * I' = -1) : ℂ →ₐ[ℝ] A :=
alg_hom.of_linear_map
  ((algebra.of_id ℝ A).to_linear_map.comp re_lm + (linear_map.to_span_singleton _ _ I').comp im_lm)
  (show algebra_map ℝ A 1 + (0 : ℝ) • I' = 1,
    by rw [ring_hom.map_one, zero_smul, add_zero])
  (λ ⟨x₁, y₁⟩ ⟨x₂, y₂⟩, show algebra_map ℝ A (x₁ * x₂ - y₁ * y₂) + (x₁ * y₂ + y₁ * x₂) • I'
                          = (algebra_map ℝ A x₁ + y₁ • I') * (algebra_map ℝ A x₂ + y₂ • I'),
    begin
      rw [add_mul, mul_add, mul_add, add_comm _ (y₁ • I' * y₂ • I'), add_add_add_comm],
      congr' 1, -- equate "real" and "imaginary" parts
      { rw [smul_mul_smul, hf, smul_neg, ←algebra.algebra_map_eq_smul_one, ←sub_eq_add_neg,
          ←ring_hom.map_mul, ←ring_hom.map_sub], },
      { rw [algebra.smul_def, algebra.smul_def, algebra.smul_def, ←algebra.right_comm _ x₂,
          ←mul_assoc, ←add_mul, ←ring_hom.map_mul, ←ring_hom.map_mul, ←ring_hom.map_add] }
    end)

@[simp]
lemma lift_aux_apply (I' : A) (hI') (z : ℂ) :
 lift_aux I' hI' z = algebra_map ℝ A z.re + z.im • I' := rfl

lemma lift_aux_apply_I (I' : A) (hI') : lift_aux I' hI' I = I' := by simp

/-- A universal property of the complex numbers, providing a unique `ℂ →ₐ[ℝ] A` for every element
of `A` which squares to `-1`.

This can be used to embed the complex numbers in the `quaternion`s.

This isomorphism is named to match the very similar `zsqrtd.lift`. -/
@[simps {simp_rhs := tt}]
def lift : {I' : A // I' * I' = -1} ≃ (ℂ →ₐ[ℝ] A) :=
{ to_fun := λ I', lift_aux I' I'.prop,
  inv_fun := λ F, ⟨F I, by rw [←F.map_mul, I_mul_I, alg_hom.map_neg, alg_hom.map_one]⟩,
  left_inv := λ I', subtype.ext $ lift_aux_apply_I I' I'.prop,
  right_inv := λ F, alg_hom_ext $ lift_aux_apply_I _ _, }

/- When applied to `complex.I` itself, `lift` is the identity. -/
@[simp]
lemma lift_aux_I : lift_aux I I_mul_I = alg_hom.id ℝ ℂ :=
alg_hom_ext $ lift_aux_apply_I _ _

/- When applied to `-complex.I`, `lift` is conjugation, `conj`. -/
@[simp]

end lift

end complex

section real_imaginary_part

open complex

variables {A : Type*} [add_comm_group A] [module ℂ A] [star_add_monoid A] [star_module ℂ A]

/-- Create a `self_adjoint` element from a `skew_adjoint` element by multiplying by the scalar
`-complex.I`. -/
@[simps] def skew_adjoint.neg_I_smul : skew_adjoint A →ₗ[ℝ] self_adjoint A :=
{ to_fun := λ a, ⟨-I • a, by simp only [self_adjoint.mem_iff, neg_smul, star_neg, star_smul,
    star_def, conj_I, skew_adjoint.star_coe_eq, neg_smul_neg]⟩,
  map_add' := λ a b, by { ext, simp only [add_subgroup.coe_add, smul_add, add_mem_class.mk_add_mk]},
  map_smul' := λ a b, by { ext, simp only [neg_smul, skew_adjoint.coe_smul, add_subgroup.coe_mk,
    ring_hom.id_apply, self_adjoint.coe_smul, smul_neg, neg_inj], rw smul_comm, } }

lemma skew_adjoint.I_smul_neg_I (a : skew_adjoint A) :
  I • (skew_adjoint.neg_I_smul a : A) = a :=
by simp only [smul_smul, skew_adjoint.neg_I_smul_apply_coe, neg_smul, smul_neg, I_mul_I, one_smul,
  neg_neg]

/-- The real part `ℜ a` of an element `a` of a star module over `ℂ`, as a linear map. This is just
`self_adjoint_part ℝ`, but we provide it as a separate definition in order to link it with lemmas
concerning the `imaginary_part`, which doesn't exist in star modules over other rings. -/
noncomputable def real_part : A →ₗ[ℝ] self_adjoint A := self_adjoint_part ℝ

/-- The imaginary part `ℑ a` of an element `a` of a star module over `ℂ`, as a linear map into the
self adjoint elements. In a general star module, we have a decomposition into the `self_adjoint`
and `skew_adjoint` parts, but in a star module over `ℂ` we have
`real_part_add_I_smul_imaginary_part`, which allows us to decompose into a linear combination of
`self_adjoint`s. -/
noncomputable
def imaginary_part : A →ₗ[ℝ] self_adjoint A := skew_adjoint.neg_I_smul.comp (skew_adjoint_part ℝ)

localized "notation `ℜ` := real_part" in complex_star_module
localized "notation `ℑ` := imaginary_part" in complex_star_module

@[simp] lemma real_part_apply_coe (a : A) :
  (ℜ a : A) = (2 : ℝ)⁻¹ • (a + star a) :=
by { unfold real_part, simp only [self_adjoint_part_apply_coe, inv_of_eq_inv]}

@[simp] lemma imaginary_part_apply_coe (a : A) :
  (ℑ a : A) = -I • (2 : ℝ)⁻¹ • (a - star a) :=
begin
  unfold imaginary_part,
  simp only [linear_map.coe_comp, skew_adjoint.neg_I_smul_apply_coe, skew_adjoint_part_apply_coe,
    inv_of_eq_inv],
end

/-- The standard decomposition of `ℜ a + complex.I • ℑ a = a` of an element of a star module over
`ℂ` into a linear combination of self adjoint elements. -/
lemma real_part_add_I_smul_imaginary_part (a : A) : (ℜ a + I • ℑ a : A) = a :=
by simpa only [smul_smul, real_part_apply_coe, imaginary_part_apply_coe, neg_smul, I_mul_I,
  one_smul, neg_sub, add_add_sub_cancel, smul_sub, smul_add, neg_sub_neg, inv_of_eq_inv]
  using inv_of_two_smul_add_inv_of_two_smul ℝ a

@[simp] lemma real_part_I_smul (a : A) : ℜ (I • a) = - ℑ a :=
by { ext, simp [smul_comm I, smul_sub, sub_eq_add_neg, add_comm] }

@[simp] lemma imaginary_part_I_smul (a : A) : ℑ (I • a) = ℜ a :=
by { ext, simp [smul_comm I, smul_smul I] }

lemma real_part_smul (z : ℂ) (a : A) : ℜ (z • a) = z.re • ℜ a - z.im • ℑ a :=
by { nth_rewrite 0 ←re_add_im z, simp [-re_add_im, add_smul, ←smul_smul, sub_eq_add_neg] }

lemma imaginary_part_smul (z : ℂ) (a : A) : ℑ (z • a) = z.re • ℑ a + z.im • ℜ a :=
by { nth_rewrite 0 ←re_add_im z, simp [-re_add_im, add_smul, ←smul_smul] }

end real_imaginary_part


import data.list.basic
open list
universe u
variables {α : Type} (x y z : α) (xs ys zs : list α)

def mk_symm (xs : list α) := xs ++ reverse xs

theorem reverse_mk_symm (xs : list α) :
  reverse (mk_symm xs) = mk_symm xs :=
  by simp [mk_symm]

run_cmd mk_simp_attr `my_simps

attribute [my_simps] reverse_mk_symm

example (xs ys : list ℕ) :
  reverse (xs ++ mk_symm ys) = mk_symm ys ++ reverse xs :=
  by simp with my_simps

example (xs ys : list ℕ) (p : list ℕ → Prop) (h : p (reverse (xs ++ (mk_symm ys)))) :
  p (mk_symm ys ++ reverse xs) :=
  by simp with my_simps at h; assumption


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import ring_theory.tensor_product

/-!
We provide the `R`-algebra structure on `matrix n n A` when `A` is an `R`-algebra,
and show `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)`.
-/

universes u v w

open_locale tensor_product
open_locale big_operators

open tensor_product
open algebra.tensor_product
open matrix

variables {R : Type u} [comm_semiring R]
variables {A : Type v} [semiring A] [algebra R A]
variables {n : Type w} [fintype n]

section
variables [decidable_eq n]

instance : algebra R (matrix n n A) :=
{ commutes' := λ r x,
  begin ext, simp [matrix.scalar, matrix.mul_apply, matrix.one_apply, algebra.commutes], end,
  smul_def' := λ r x, begin ext, simp [matrix.scalar, algebra.smul_def'' r], end,
  ..((matrix.scalar n).comp (algebra_map R A)) }

lemma algebra_map_matrix_apply {r : R} {i j : n} :
  algebra_map R (matrix n n A) r i j = if i = j then algebra_map R A r else 0 :=
begin
  dsimp [algebra_map, algebra.to_ring_hom, matrix.scalar],
  split_ifs with h; simp [h, matrix.one_apply_ne],
end
end

variables (R A n)
namespace matrix_equiv_tensor

/--
(Implementation detail).
The bare function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`, on pure tensors.
-/
def to_fun (a : A) (m : matrix n n R) : matrix n n A :=
λ i j, a * algebra_map R A (m i j)

/--
(Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-linear map in the second tensor factor.
-/
def to_fun_right_linear (a : A) : matrix n n R →ₗ[R] matrix n n A :=
{ to_fun := to_fun R A n a,
  map_add' := λ x y, by { dsimp only [to_fun], ext, simp [mul_add], },
  map_smul' := λ r x,
  begin
    dsimp only [to_fun],
    ext,
    simp only [matrix.smul_apply, pi.smul_apply, ring_hom.map_mul,
      algebra.id.smul_eq_mul, ring_hom.map_mul],
    rw [algebra.smul_def r, ←_root_.mul_assoc, ←_root_.mul_assoc, algebra.commutes],
  end, }

/--
(Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-bilinear map.
-/
def to_fun_bilinear : A →ₗ[R] matrix n n R →ₗ[R] matrix n n A :=
{ to_fun := to_fun_right_linear R A n,
  map_add' := λ x y, by { ext, simp [to_fun_right_linear, to_fun, add_mul], },
  map_smul' := λ r x, by { ext, simp [to_fun_right_linear, to_fun] }, }

/--
(Implementation detail).
The function underlying `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`,
as an `R`-linear map.
-/
def to_fun_linear : A ⊗[R] matrix n n R →ₗ[R] matrix n n A :=
tensor_product.lift (to_fun_bilinear R A n)

variables [decidable_eq n]

/--
The function `(A ⊗[R] matrix n n R) →ₐ[R] matrix n n A`, as an algebra homomorphism.
-/
def to_fun_alg_hom : (A ⊗[R] matrix n n R) →ₐ[R] matrix n n A :=
alg_hom_of_linear_map_tensor_product
(to_fun_linear R A n)
begin
  intros, ext,
  simp_rw [to_fun_linear, to_fun_bilinear, lift.tmul],
  dsimp,
  simp_rw [to_fun_right_linear],
  dsimp,
  simp_rw [to_fun, matrix.mul_mul_left, matrix.smul_apply, matrix.mul_apply,
    ←_root_.mul_assoc _ a₂ _, algebra.commutes, _root_.mul_assoc a₂ _ _, ←finset.mul_sum,
    ring_hom.map_sum, ring_hom.map_mul, _root_.mul_assoc],
end
begin
  intros, ext,
  simp only [to_fun_linear, to_fun_bilinear, to_fun_right_linear, to_fun, matrix.one_apply,
    algebra_map_matrix_apply, lift.tmul, linear_map.coe_mk],
  split_ifs; simp,
end

@[simp] lemma to_fun_alg_hom_apply (a : A) (m : matrix n n R) :
  to_fun_alg_hom R A n (a ⊗ₜ m) = λ i j, a * algebra_map R A (m i j) :=
begin
  simp [to_fun_alg_hom, alg_hom_of_linear_map_tensor_product, to_fun_linear],
  refl,
end

/--
(Implementation detail.)

The bare function `matrix n n A → A ⊗[R] matrix n n R`.
(We don't need to show that it's an algebra map, thankfully --- just that it's an inverse.)
-/
def inv_fun (M : matrix n n A) : A ⊗[R] matrix n n R :=
∑ (p : n × n), M p.1 p.2 ⊗ₜ (std_basis_matrix p.1 p.2 1)

@[simp] lemma inv_fun_zero : inv_fun R A n 0 = 0 :=
by simp [inv_fun]

@[simp] lemma inv_fun_add (M N : matrix n n A) :
  inv_fun R A n (M + N) = inv_fun R A n M + inv_fun R A n N :=
by simp [inv_fun, add_tmul, finset.sum_add_distrib]

@[simp] lemma inv_fun_smul (a : A) (M : matrix n n A) :
  inv_fun R A n (λ i j, a * M i j) = (a ⊗ₜ 1) * inv_fun R A n M :=
by simp [inv_fun,finset.mul_sum]

@[simp] lemma inv_fun_algebra_map (M : matrix n n R) :
  inv_fun R A n (λ i j, algebra_map R A (M i j)) = 1 ⊗ₜ M :=
begin
  dsimp [inv_fun],
  simp only [algebra.algebra_map_eq_smul_one, smul_tmul, ←tmul_sum, mul_boole],
  congr,
  conv_rhs {rw matrix_eq_sum_std_basis M},
  convert finset.sum_product, simp,
end

lemma right_inv (M : matrix n n A) : (to_fun_alg_hom R A n) (inv_fun R A n M) = M :=
begin
  simp only [inv_fun, alg_hom.map_sum, std_basis_matrix, apply_ite ⇑(algebra_map R A),
    mul_boole, to_fun_alg_hom_apply, ring_hom.map_zero, ring_hom.map_one],
  convert finset.sum_product, apply matrix_eq_sum_std_basis,
end

lemma left_inv (M : A ⊗[R] matrix n n R) : inv_fun R A n (to_fun_alg_hom R A n M) = M :=
begin
  apply tensor_product.induction_on M,
  { simp, },
  { intros a m, simp, },
  { intros x y hx hy, simp [alg_hom.map_sum, hx, hy], },
end

/--
(Implementation detail)

The equivalence, ignoring the algebra structure, `(A ⊗[R] matrix n n R) ≃ matrix n n A`.
-/
def equiv : (A ⊗[R] matrix n n R) ≃ matrix n n A :=
{ to_fun := to_fun_alg_hom R A n,
  inv_fun := inv_fun R A n,
  left_inv := left_inv R A n,
  right_inv := right_inv R A n, }

end matrix_equiv_tensor

variables [decidable_eq n]

/--
The `R`-algebra isomorphism `matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R)`.
-/
def matrix_equiv_tensor : matrix n n A ≃ₐ[R] (A ⊗[R] matrix n n R) :=
alg_equiv.symm { ..(matrix_equiv_tensor.to_fun_alg_hom R A n), ..(matrix_equiv_tensor.equiv R A n) }

open matrix_equiv_tensor

@[simp] lemma matrix_equiv_tensor_apply (M : matrix n n A) :
  matrix_equiv_tensor R A n M =
    ∑ (p : n × n), M p.1 p.2 ⊗ₜ (std_basis_matrix p.1 p.2 1) :=
rfl

@[simp] lemma matrix_equiv_tensor_apply_std_basis (i j : n) (x : A):
  matrix_equiv_tensor R A n (std_basis_matrix i j x) =
    x ⊗ₜ (std_basis_matrix i j 1) :=
begin
  have t : ∀ (p : n × n), (p.1 = i ∧ p.2 = j) ↔ (p = (i, j)) := by tidy,
  simp [ite_tmul, t, std_basis_matrix],
end

@[simp] lemma matrix_equiv_tensor_apply_symm (a : A) (M : matrix n n R) :
  (matrix_equiv_tensor R A n).symm (a ⊗ₜ M) =
    λ i j, a * algebra_map R A (M i j) :=
begin
  simp [matrix_equiv_tensor, to_fun_alg_hom, alg_hom_of_linear_map_tensor_product, to_fun_linear],
  refl,
end


import data.matrix.basic

universe variables u v

namespace matrix
variables {l m n o : Type u} [fintype l] [fintype m] [fintype n] [fintype o]
variables {α : Type v}

open_locale matrix

section trace

def trace [add_comm_monoid α] (M : matrix m m α) : α :=
finset.univ.sum (λ i, M i i)

variables {L M N : matrix m m α}

@[simp] lemma trace_transpose [add_comm_monoid α] :
  Mᵀ.trace = M.trace :=
rfl

lemma trace_add [add_comm_monoid α] :
  (M + N).trace = M.trace + N.trace :=
finset.sum_add_distrib

lemma trace_smul [ring α] {a : α} :
  (a • M).trace = a * M.trace :=
finset.mul_sum.symm

lemma trace_comm [comm_ring α] :
  (M ⬝ N).trace = (N ⬝ M).trace :=
begin
  classical,
  unfold trace,
  dsimp [(⬝)],
  rw finset.sum_comm,
  simp only [mul_comm],
end

lemma trace_zero [add_comm_monoid α] :
  trace (0 : matrix m m α) = 0 :=
by simp only [trace, add_monoid.smul_zero, finset.sum_const, matrix.zero_val]

lemma trace_diagonal [add_comm_monoid α] [decidable_eq m] {d : m → α} :
  trace (diagonal d) = finset.univ.sum d :=
by simp [trace, diagonal]

lemma trace_one [decidable_eq m] [add_comm_monoid α] [has_one α] :
  trace (1 : matrix m m α) = (fintype.card m : α) :=
begin
  unfold has_one.one,
  rw [trace_diagonal, finset.sum_const, add_monoid.smul_one],
  refl,
end

end trace

end matrix


    -- Tao's Analysis I Chapter 2 Results

-- The aim of this project is to adhere as strictly as reasonable
-- to the textbook, sometimes even at the cost of clarity.
-- However, as a result, this project comes close to serving
-- as a fully formalized solutions manual for the textbook.

namespace chapter2

open nat
open classical

-- Predefined Lean library theorems may appear in other places,
-- but are mainly used only to prove the basic axioms.

-- Since in Lean the natural numbers are defined inductively,
-- the "Peano Axioms" will be results instead of "axioms".

local postfix `++` := succ

-- 0 is a natural number
theorem ax2_1 : ℕ := 0

-- If n is a natural number, then n++ is a natural number
theorem ax2_2 (n : ℕ) : ℕ := n++

theorem p2_1_4 : ℕ := 3
example : ℕ := ax2_2 $ ax2_2 $ ax2_2 ax2_1

-- 0 is not the succesor of any natural number
theorem ax2_3 : ∀ {n : ℕ}, n++ ≠ 0 := succ_ne_zero

theorem p2_1_6 : 4 ≠ 0 := ax2_3

theorem ax2_4 {n m : ℕ} : n++ = m++ → n = m :=
assume h : n++ = m++,
nat.no_confusion h id

theorem p2_1_8 : 6 ≠ 2 :=
not.intro (assume h : 6 = 2,
    have h₂ : 5 = 1, from ax2_4 h,
    have h₃ : 4 = 0, from ax2_4 h₂,
    show false, from p2_1_6 h₃)

-- Note that Lean has induction built into inductive datatypes
-- The "inductive" tactic will be used most frequently
theorem ax2_5 (P : ℕ → Prop) (h₀ : P 0) (ih : ∀ n, P n → P (n++)) : ∀ n, P n :=
assume n : ℕ, @nat.rec_on P n h₀ ih

theorem p2_1_16 (fₙ : ℕ → ℕ) (c : ℕ) : ℕ → ℕ
| 0     := c
| (a++) := fₙ a

-- Once all relevant properties have been proved,
-- Lean's natural numbers and "add" will be used instead
def d2_2_1 : ℕ → ℕ → ℕ
| 0     m := m
| (n++) m := (d2_2_1 n m)++
def tempadd := d2_2_1
local infix `+` := tempadd

lemma l2_2_2 : ∀ {n : ℕ}, n + 0 = n :=
begin
    intro n,
    apply nat.rec_on n,
    reflexivity,
    intro n,
    intro ih,
    exact calc
        n++ + 0 = (n+0)++ : rfl
        ...     = n++     : congr_arg nat.succ ih
end

lemma l2_2_3 : ∀ {n m}, n + (m++) = (n + m)++ :=
begin
    intros n m,
    apply nat.rec_on n,
    show 0 + (m++) = (0 + m)++, from calc
        0 + (m++) = m++       : rfl
        ...       = (0 + m)++ : rfl,
    intro n,
    intro ih,
    show (n++) + (m++) = ((n++) + m)++, from calc
        (n++) + (m++) = (n + (m++))++ : rfl
        ...           = ((n + m)++)++ : congr_arg nat.succ ih
        ...           = ((n++) + m)++ : rfl
end

-- See nat.add_comm
theorem p2_2_4 : ∀ {n m}, n + m = m + n :=
begin
    intros n m,
    apply nat.rec_on n,
    show 0 + m = m + 0, from calc
        0 + m = m     : rfl
        ...   = m + 0 : eq.symm $ l2_2_2,
    intro n,
    intro ih,
    show (n++) + m = m + (n++), from calc
        (n++) + m = (n + m)++ : rfl
        ...       = (m + n)++ : congr_arg _ ih
        ...       = m + (n++) : eq.symm $ l2_2_3
end

-- See nat.add_assoc
theorem p2_2_5 : ∀ {a b c}, (a + b) + c = a + (b + c) :=
begin
    intros a b c,
    apply nat.rec_on c,
    show (a + b) + 0 = a + (b + 0), from calc
        (a + b) + 0 = a + b       : l2_2_2
        ...         = a + (b + 0) : congr_arg _ (eq.symm l2_2_2),
    intro c,
    intro ih,
    show (a + b) + (c++) = a + (b + (c++)), from calc
        (a + b) + (c++) = ((a + b) + c)++ : l2_2_3
        ...             = (a + (b + c))++ : congr_arg _ ih
        ...             = a + ((b + c)++) : eq.symm l2_2_3
        ...             = a + (b + (c++)) : congr_arg _ (eq.symm l2_2_3)
end

theorem p2_2_6 : ∀ {a b c}, a + b = a + c → b = c :=
begin
    intros a b c,
    induction a with a ih,
    intro,
    exact calc
            b     = 0 + b : rfl
            ...   = 0 + c : by assumption
            ...   = c     : rfl,
    intro,
    have : (a + b)++ = (a + c)++, from calc
        (a + b)++ = (a++) + b : rfl
        ...       = (a++) + c : by assumption
        ...       = (a + c)++ : rfl,
    have : a + b = a + c, from ax2_4 this,
    show b = c, from ih this
end

def d2_2_7 (n : ℕ) : Prop := n ≠ 0
def pos := d2_2_7

-- extra
lemma zero_neq_one : pos 1 :=
begin

end

theorem p2_2_8 : ∀ a b, pos a → pos (a + b) :=
begin
    intros a b pa,
    induction b with b ih,
    have : a + 0 = a, from l2_2_2,
    exact eq.substr this pa,
    have h : a + (b++) = (a + b)++, from l2_2_3,
    have : pos ((a + b)++), from ax2_3,
    exact eq.substr h this
end

theorem c2_2_9 : ∀ {a b}, a + b = 0 → a = 0 ∧ b = 0 :=
begin
    intros a b h,
    constructor,
    apply by_contradiction,
    intro na,
    have : pos a, from na,
    have : pos (a + b), from p2_2_8 a b this,
    exact this h,
    apply by_contradiction,
    intro nb,
    have : pos b, from nb,
    have : pos (b + a), from p2_2_8 b a this,
    have : pos (a + b), from eq.subst (@p2_2_4 b a) this,
    exact this h
end

lemma l2_2_10 : ∀ {a}, pos a → ∃! b, b++ = a :=
begin
    intros a pa,
    induction a with a ih,
    have : ¬pos 0, from not.intro
    (assume h : 0 ≠ 0, h (@rfl ℕ 0)),
    exact false.elim (this pa),
    apply exists_unique.intro a,
    reflexivity,
    intro y,
    exact ax2_4
end

section ordering_properties

-- See ge (≥) and less_than_or_equal
-- Lean uses alternate definitions based on inductive types
-- We make use of the predefined ordering typeclass for convenience
def d2_2_11a (n m : ℕ) : Prop :=
∃ a : ℕ, n = m + a
def ge := d2_2_11a
def le (n m : ℕ) := ge m n
instance : has_le ℕ := ⟨le⟩

-- See gt (>)
def d2_2_11b (n m : ℕ) : Prop :=
(d2_2_11a n m) ∧ n ≠ m
def gt := d2_2_11b
def lt (n m : ℕ) := gt m n
instance : has_lt ℕ := ⟨lt⟩

variables {a b c : ℕ}

theorem p2_2_12a : a ≥ a :=
begin
    apply exists.intro 0,
    exact eq.symm l2_2_2
end

theorem p2_2_12b : a ≥ b ∧ b ≥ c → a ≥ c :=
begin
    intro h,
    cases h with ageb bgec,
    have ab : ∃ m, a = b + m, from ageb,
    have bc : ∃ n, b = c + n, from bgec,
    clear ageb bgec,
    change (∃ k, a = c + k),
    cases ab with m h₁,
    cases bc with n h₂,
    apply exists.intro,
    change a = c + (n + m),
    exact calc
        a   = b + m       : h₁
        ... = c + n + m   : congr_arg _ h₂
        ... = c + (n + m) : p2_2_5
end

theorem p2_2_12c : a ≥ b ∧ b ≥ a → a = b :=
begin
    intro h,
    cases h with aa bb,
    have ab : ∃ m, a = b + m, from aa,
    have ba : ∃ n, b = a + n, from bb,
    clear aa bb,
    cases ab with m h₁,
    cases ba with n h₂,
    have : a = a + (n + m), from calc
        a   = b + m       : h₁
        ... = a + n + m   : congr_arg _ h₂
        ... = a + (n + m) : p2_2_5,
    have : a + 0 = a + (n + m),
        rw l2_2_2, assumption,
    have : 0 = n + m, from p2_2_6 this,
    have : n = 0 ∧ m = 0, from c2_2_9 (eq.symm this),
    cases this with n0 m0,
    exact calc
        a   = b + m : h₁
        ... = b + 0 : by rw m0
        ... = b     : l2_2_2
end

theorem p2_2_12d : a ≥ b ↔ a + c ≥ b + c :=
begin
    constructor,
    intro,
        have ab : ∃ m, a = b + m, assumption,
        cases ab with m h,
        apply exists.intro m,
        show a + c = b + c + m, from calc
            a + c = a + c       : rfl
            ...   = b + m + c   : by rw h
            ...   = b + (m + c) : by rw p2_2_5
            ...   = b + (c + m) : by rw (@p2_2_4 c m)
            ...   = b + c + m   : by rw ← p2_2_5,
    intro,
        have acbc : ∃ m, a + c = b + c + m, assumption,
        cases acbc with m h,
        constructor,
        change a = b + m,
        have : a + c = c + (b + m),
            rw [h, (@p2_2_4 b c), p2_2_5],
        have : c + a = c + (b + m),
            rw p2_2_4, assumption,
        show a = b + m, from p2_2_6 this
end

theorem p2_2_12e : a < b ↔ a++ ≤ b :=
begin
    constructor,
    intro,
        have ab : (∃ m, b = a + m) ∧ b ≠ a, assumption,
        cases ab with em ne,
        cases em with m ba,
        have mn0 : m ≠ 0,
            assume : m = 0,
            have : b = a, rw [ba, this, l2_2_2], from
            ne this,
        have : ∃! d, d++ = m, from l2_2_10 mn0,
        cases this with d h₁,
        cases h₁ with h₂ h₃,
        constructor,
        show b = (a++) + d, from calc
            b   = a + m     : ba
            ... = a + (d++) : by rw h₂
            ... = (a + d)++ : by rw l2_2_3
            ... = (a++) + d : rfl,
    intro,
        have ab : ∃ m, b = (a++) + m, assumption,
        constructor,
        change ∃ d, b = a + d,
        cases ab with m ab,
        constructor,
        show b = a + (m++), from calc
            b = (a++) + m : ab
            ... = (a + m)++ : rfl
            ... = a + (m++) : by rw ← l2_2_3,
        cases ab with m ab,
        assume : b = a,
        have : b = a + (m++), from calc
            b = (a++) + m : ab
            ... = (a + m)++ : rfl
            ... = a + (m++) : by rw ← l2_2_3,
        have : a + (m++) = b, from eq.symm this,
        have : a + (m++) = a + 0, rw [this, ‹b = a›, l2_2_2],
        have : (m++) = 0, from p2_2_6 this,
        exact ax2_3 this
end

theorem p2_2_12f : a < b ↔ ∃ d, b = a + d ∧ pos d :=
begin
    constructor,
    intro ab,
        cases ab with ab ne,
        have ab : ∃ d, b = a + d, assumption,
        cases ab with d ab,
        constructor,
        constructor,
        exact ab,
        assume : d = 0,
        have : b = a, rw [ab, this, l2_2_2],
        contradiction,
    intro h,
        cases h with d h,
        cases h with ba pd,
        constructor,
        constructor,
        exact ba,
        assume : b = a,
        have ba : b + 0 = a + d, rw [ba, l2_2_2],
        have ba : a + d = b + 0, from eq.symm ba,
        have : a + d = a + 0, rw [ba, this],
        have : d = 0, from p2_2_6 this,
        contradiction
end

end ordering_properties

section order_trichotomy

variables {a b : ℕ}

lemma p2_2_13_l1_l1 : b++ ≠ b :=
begin
    induction b with b ih,
    exact ax2_3,
    assume : (b++)++ = b++,
    have : b++ = b, exact ax2_4 this,
    contradiction
end

lemma p2_2_13_l1 : (a < b ∨ a = b ∨ a > b) :=
begin
    induction a with a ih,
    have : 0 ≤ b,
        constructor,
        change b = 0 + b,
        reflexivity,
    apply by_cases,
        assume (eq : b = 0), right, left, exact eq.symm,
        assume (ne : b ≠ 0),
            have : 0 < b, constructor, assumption, assumption,
            left, assumption,
    cases ih with ablt ih,
        have : a++ ≤ b, from p2_2_12e.mp ablt,
        apply by_cases,
            assume (eq : b = a++), right, left, exact eq.symm,
            assume (ne : b ≠ a++),
                have : a++ < b, constructor, assumption, assumption,
                left, assumption,
    cases ih with abeq abgt,
    right, right,
        constructor,
        constructor,
            show a++ = b + (0++), rw [← abeq, l2_2_3, l2_2_2],
        rw abeq,
        exact p2_2_13_l1_l1,
    right, right,
        cases abgt with abge ne,
        cases abge with m ab,
        constructor,
        constructor,
        change a++ = b + (m++),
        rw [ab, ← l2_2_3],
        assume : a++ = b,
        rw [← @l2_2_2 b, ab, ← l2_2_3] at this,
        have : (m++) = 0, from p2_2_6 this,
        apply ax2_3,
        exact this
end

lemma p2_2_13_l2 : ¬(a = b ∧ a > b) :=
begin
    apply not.intro,
    intro h,
    cases h with eq gt,
    cases gt with ge ne,
    contradiction
end

lemma p2_2_13_l3 : ¬(a = b ∧ a < b) :=
begin
    apply not.intro,
    intro h,
    cases h with eq lt,
    cases lt with le ne,
    have : b = a, from eq.symm,
    contradiction
end

lemma p2_2_13_l4 : ¬(a > b ∧ a < b) :=
begin
    apply not.intro,
    intro h,
    cases h with gt lt,
    cases gt with ge ne,
    cases lt with le ne,
    have : a = b, from p2_2_12c ⟨ge, le⟩,
    contradiction
end

theorem p2_2_13 : (a < b ∨ a = b ∨ a > b) ∧
    ¬(a = b ∧ a > b) ∧ ¬(a = b ∧ a < b) ∧ ¬(a > b ∧ a < b) :=
⟨p2_2_13_l1, p2_2_13_l2, p2_2_13_l3, p2_2_13_l4⟩

end order_trichotomy

section strong_induction

lemma strong_ind_simp_l1 : ∀ {m n : ℕ}, m < n++ → m ≤ n :=
begin
    intros m n h,
    have : (m++) ≤ (n++), from p2_2_12e.mp h,
    cases this with k h₂,
    constructor,
    have : n++ = (m + k)++, assumption,
    show n = m + k, from ax2_4 this
end

lemma strong_ind_simp_l2 : ∀ {a b : ℕ}, a ≤ b → a < b ∨ a = b :=
begin
    intros a b ab,
    cases ab with k ab,
    apply by_cases,
    assume : k = 0,
        rw [‹k = 0›, l2_2_2] at ab,
        right, exact ab.symm,
    assume : k ≠ 0,
        left,
        apply p2_2_12f.mpr,
        constructor,
        exact ⟨ab, this⟩
end

-- A simpler example that starts at 0 instead of m₀
lemma strong_ind_simple (P : ℕ → Prop) (k : ℕ)
    (hh : ∀ n, (∀ m, m < n → P m) → P n) : P k :=
begin
    let Q : ℕ → Prop := λ n, ∀ m, m < n → P m,
    have hq : ∀ {n : ℕ}, Q n → P n, assumption,
    have qk : Q k,
        induction k with k qk,
        intros n h,
            cases h with k h,
            cases k with k h₂,
            have : 0 = n, rw ← (c2_2_9 h₂.symm).left,
            contradiction,
        intros m h,
            have : m < k ∨ m = k, from (strong_ind_simp_l2 (strong_ind_simp_l1 h)),
            cases this with ltk eqk,
            apply qk, assumption,
            subst m, apply hq, assumption,
    exact hq qk
end

theorem p2_2_14 (m₀ : ℕ) (P : ℕ → Prop) (k : ℕ)
    (hh : ∀ m, (∀ m', m₀ ≤ m' ∧ m' < m → P m') → P m)
    : ∀ k, k ≥ m₀ → P k :=
begin
    intros k h,
    let Q : ℕ → Prop := λ m, ∀ m', m₀ ≤ m' ∧ m' < m → P m',
    have hq : ∀ {n : ℕ}, Q n → P n, assumption,
    have qk : Q k,
        induction k with k qk,
        intros m hand,
            have : m < 0, from hand.right,
            cases this with h₂ ne,
            cases h₂ with c h₂,
            have : 0 = m, rw ← (c2_2_9 h₂.symm).left,
            contradiction,
        intros m hand,
            cases hand with hl hr,
            have : m < k ∨ m = k, from (strong_ind_simp_l2 (strong_ind_simp_l1 hr)),
            cases this with ltk eqk,
            apply qk,
                cases ltk with km ne,
                have km : k ≥ m, from km,
                exact p2_2_12b ⟨km, hl⟩,
                exact ⟨hl, ltk⟩,
            rw eqk, apply hq, apply qk,
            rw ← eqk, exact hl,
    exact hq qk
end

end strong_induction

theorem ex2_2_6 (n m : ℕ) (P : ℕ → Prop) (h : ∀ {m}, P (m++) → P m)
    (h₀ : P n) : m ≤ n → P m :=
begin
    intro mn,
    induction n with n ih,
    cases mn with k mk,
    rw (c2_2_9 mk.symm).left, assumption,
    have : m < n++ ∨ m = n++, from strong_ind_simp_l2 mn,
    cases this with mlt meq,
    have : m++ ≤ n++, from p2_2_12e.mp mlt,
    rw [← (@l2_2_2 m), ← (@l2_2_2 n)] at this,
    rw [← l2_2_3, ← l2_2_3] at this,
    have : m ≤ n, from p2_2_12d.mpr this,
    exact ih (h h₀) this,
    rw meq, exact h₀
end

def d2_3_1 : ℕ → ℕ → ℕ
| 0     m := 0
| (n++) m := (d2_3_1 n m) + m
def tempmul := d2_3_1
local infix `*` := tempmul

lemma l2_3_2_l1 {n : ℕ} : n * 0 = 0 :=
begin
    induction n with n ih,
    reflexivity,
    change (n * 0) + 0 = 0,
    rw l2_2_2, assumption
end

lemma l2_3_2_l2_l1 {a b c : ℕ} : b = c → a + b = a + c :=
begin
    intro h,
    induction a with a ih,
    exact h,
    change (a + b)++ = (a + c)++,
    rw ih
end

lemma l2_3_2_l2 {n m : ℕ} : n * (m++) = n * m + n :=
begin
    induction n with n ih,
    change 0 = 0 * m + 0,
    rw l2_2_2, reflexivity,
    change (n * (m++)) + (m++) = (n * m) + m + (n++),
    rw ih,
    rw p2_2_5, rw p2_2_5,
    rw l2_3_2_l2_l1,
    rw l2_2_3, rw l2_2_3,
    rw p2_2_4
end

lemma l2_3_2 {n m : ℕ} : n * m = m * n :=
begin
    induction n with n ih,
    rw l2_3_2_l1, reflexivity,
    change (n * m) + m = m * (n++),
    rw l2_3_2_l2,
    rw ih
end

lemma l2_3_3a_l1 {n m : ℕ} : (n * m) + m = 0 → m = 0 :=
begin
    intro h,
    induction m with m ih,
    reflexivity,
    rw l2_3_2_l2 at h,
    by_contradiction,
    have : (m++) = 0, from (c2_2_9 h).right,
    contradiction
end

lemma l2_3_3a {n m : ℕ} : n * m = 0 ↔ n = 0 ∨ m = 0 :=
begin
    constructor,
    intro h,
        induction n with n ih,
        left, reflexivity,
        unfold tempmul at h,
        unfold d2_3_1 at h,
        right, exact l2_3_3a_l1 h,
    intro h,
        cases h with h h,
        rw h, reflexivity,
        rw h, rw l2_3_2_l1
end

lemma l2_3_3b {n m : ℕ} : pos n ∧ pos m ↔ pos (n * m) :=
begin
    constructor,
    intro h,
        cases h with pn pm,
        assume : n * m = 0,
        have : n = 0 ∨ m = 0, from l2_3_3a.mp this,
        cases this, contradiction, contradiction,
    intro h,
        constructor,
        assume : n = 0,
            rw this at h,
            change pos 0 at h,
            exact ne.irrefl h,
        assume : m = 0,
            rw this at h,
            rw l2_3_2_l1 at h,
            exact ne.irrefl h,
end

theorem p2_3_4a {a b c : ℕ} : a * (b + c) = (a * b) + (a * c) :=
begin
    induction c with c ih,
    rw [l2_2_2, l2_3_2_l1, l2_2_2],
    rw [l2_2_3, l2_3_2_l2, ih, l2_3_2_l2, p2_2_5]
end

theorem p2_3_4b {a b c : ℕ} : (b + c) * a = (b * a) + (c * a) :=
begin
   rw [l2_3_2, @l2_3_2 b a, @l2_3_2 c a],
   exact p2_3_4a
end

theorem p2_3_5 {a b c : ℕ} : (a * b) * c = a * (b * c) :=
begin
    induction b with b ih,
    rw l2_3_2_l1,
    change 0 = a * 0,
    rw l2_3_2_l1,
    rw [l2_3_2_l2, p2_3_4b],
    change a * b * c + a * c = a * (b * c + c),
    rw p2_3_4a,
    rw ih.symm
end

theorem p2_3_6 {a b c : ℕ} : a < b → pos c → a * c < b * c :=
begin
    intros h pc,
    have, from p2_2_12f.mp h,
    cases this with d h,
    cases h with h pd,
    have : b * c = (a + d) * c, from h ▸ rfl,
    rw p2_3_4b at this,
    have pdc : pos (d * c), from l2_3_3b.mp ⟨pd, pc⟩,
    apply p2_2_12f.mpr,
    constructor, exact ⟨this, pdc⟩
end

theorem c2_3_7 {a b c : ℕ} : a * c = b * c → pos c → a = b :=
begin
    intros h pc,
    have tri : a < b ∨ a = b ∨ a > b, from p2_2_13_l1,
    cases tri with ablt tri,
        have : a * c < b * c, from p2_3_6 ablt pc,
        cases this, have h, from eq.symm h,
        contradiction,
    cases tri with abeq abgt, assumption,
        have : a * c > b * c, from p2_3_6 abgt pc,
        cases this,
        contradiction
end

theorem p2_3_9 {n q : ℕ} (pq : pos q) :
    ∃ m r, 0 ≤ r ∧ r < q ∧ n = m * q + r :=
begin
    induction n with n ih,
    repeat {constructor}, contradiction,
    rw [l2_2_2, l2_2_2], change 0 = 0 * q, reflexivity,
    cases ih with m ih,
    cases ih with r ih,
    cases ih with r₀ ih,
    cases ih with rq ih,
    have : r++ ≤ q, from p2_2_12e.mp rq,
    have : r++ < q ∨ r++ = q, from strong_ind_simp_l2 this,
    cases this with rlt req,
    existsi m, existsi (r++),
        constructor, constructor, reflexivity,
        constructor, exact rlt,
        rw [ih, l2_2_3],
    existsi (m++), existsi 0,
    constructor, constructor, reflexivity,
    constructor, constructor, constructor, reflexivity, exact pq,
    change n++ = m * q + q + 0,
    rw [ih, l2_2_2, ← l2_2_3, req]
end

def d2_3_11 : ℕ → ℕ → ℕ
| m 0     := 1
| m (n++) := (d2_3_11 m n) * m
def tempexp := d2_3_11
local infix `^` := tempexp

example {x : ℕ} : x ^ 3 = x ^ 2 * x := rfl
example {x : ℕ} : x ^ 3 = x * x * x := rfl

lemma ex2_3_4_l1 {n : ℕ} : n + n = 2 * n := rfl

theorem ex2_3_4 {a b : ℕ} :
    (a + b) ^ 2 = a ^ 2 + 2 * a * b + b ^ 2 :=
calc
    (a + b) ^ 2 = (a + b) * (a + b) : rfl
    ...         = (a + b) * a + (a + b) * b : p2_3_4a
    ...         = a * a + b * a + (a + b) * b : by rw p2_3_4b
    ...         = a * a + b * a + (a * b + b * b) : by rw p2_3_4b
    ...         = a * a + b * a + a * b + b * b : by rw ← p2_2_5
    ...         = a ^ 2 + b * a + a * b + b ^ 2 : rfl
    ...         = a ^ 2 + a * b + a * b + b ^ 2 : by rw l2_3_2
    ...         = a ^ 2 + (a * b + a * b) + b ^ 2 : by rw ← p2_2_5
    ...         = a ^ 2 + 2 * (a * b) + b ^ 2 : by rw ex2_3_4_l1
    ...         = a ^ 2 + 2 * a * b + b ^ 2 : by rw p2_3_5

end chapter2

-- We will now assume and employ theorems regarding
-- the natural numbers from Lean's standard library since
-- they are no longer the focus of any future chapters.


import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.int.basic
import data.nat.factorization.prime_pow
import algebra.squarefree

/-!
# Lemmas about squarefreeness of natural numbers
A number is squarefree when it is not divisible by any squares except the squares of units.

## Main Results
 - `nat.squarefree_iff_nodup_factors`: A positive natural number `x` is squarefree iff
  the list `factors x` has no duplicate factors.

## Tags
squarefree, multiplicity

-/

namespace nat

lemma squarefree_iff_nodup_factors {n : ℕ} (h0 : n ≠ 0) :
  squarefree n ↔ n.factors.nodup :=
begin
  rw [unique_factorization_monoid.squarefree_iff_nodup_normalized_factors h0, nat.factors_eq],
  simp,
end

theorem squarefree_iff_prime_squarefree {n : ℕ} : squarefree n ↔ ∀ x, prime x → ¬ x * x ∣ n :=
squarefree_iff_irreducible_sq_not_dvd_of_exists_irreducible ⟨_, prime_two⟩

lemma squarefree.factorization_le_one {n : ℕ} (p : ℕ) (hn : squarefree n) :
  n.factorization p ≤ 1 :=
begin
  rcases eq_or_ne n 0 with rfl | hn',
  { simp },
  rw [multiplicity.squarefree_iff_multiplicity_le_one] at hn,
  by_cases hp : p.prime,
  { have := hn p,
    simp only [multiplicity_eq_factorization hp hn', nat.is_unit_iff, hp.ne_one, or_false] at this,
    exact_mod_cast this },
  { rw factorization_eq_zero_of_non_prime _ hp,
    exact zero_le_one }
end

lemma squarefree_of_factorization_le_one {n : ℕ} (hn : n ≠ 0) (hn' : ∀ p, n.factorization p ≤ 1) :
  squarefree n :=
begin
  rw [squarefree_iff_nodup_factors hn, list.nodup_iff_count_le_one],
  intro a,
  rw factors_count_eq,
  apply hn',
end

lemma squarefree_iff_factorization_le_one {n : ℕ} (hn : n ≠ 0) :
  squarefree n ↔ ∀ p, n.factorization p ≤ 1 :=
⟨λ p hn, squarefree.factorization_le_one hn p, squarefree_of_factorization_le_one hn⟩

lemma squarefree_pow_iff {n k : ℕ} (hn : n ≠ 1) (hk : k ≠ 0) :
  squarefree (n ^ k) ↔ squarefree n ∧ k = 1 :=
begin
  refine ⟨λ h, _, by { rintro ⟨hn, rfl⟩, simpa }⟩,
  rcases eq_or_ne n 0 with rfl | hn₀,
  { simpa [zero_pow hk.bot_lt] using h },
  refine ⟨squarefree_of_dvd_of_squarefree (dvd_pow_self _ hk) h, by_contradiction $ λ h₁, _⟩,
  have : 2 ≤ k := k.two_le_iff.mpr ⟨hk, h₁⟩,
  apply hn (nat.is_unit_iff.1 (h _ _)),
  rw ←sq,
  exact pow_dvd_pow _ this
end

lemma squarefree_and_prime_pow_iff_prime {n : ℕ} :
  squarefree n ∧ is_prime_pow n ↔ prime n :=
begin
  refine iff.symm ⟨λ hn, ⟨hn.squarefree, hn.is_prime_pow⟩, _⟩,
  rw is_prime_pow_nat_iff,
  rintro ⟨h, p, k, hp, hk, rfl⟩,
  rw squarefree_pow_iff hp.ne_one hk.ne' at h,
  rwa [h.2, pow_one],
end

/-- Assuming that `n` has no factors less than `k`, returns the smallest prime `p` such that
  `p^2 ∣ n`. -/
def min_sq_fac_aux : ℕ → ℕ → option ℕ
| n k :=
  if h : n < k * k then none else
  have nat.sqrt n + 2 - (k + 2) < nat.sqrt n + 2 - k,
    by { rw nat.add_sub_add_right, exact nat.min_fac_lemma n k h },
  if k ∣ n then
    let n' := n / k in
    have nat.sqrt n' + 2 - (k + 2) < nat.sqrt n + 2 - k, from
      lt_of_le_of_lt (nat.sub_le_sub_right
        (nat.add_le_add_right (nat.sqrt_le_sqrt $ nat.div_le_self _ _) _) _) this,
    if k ∣ n' then some k else min_sq_fac_aux n' (k + 2)
  else min_sq_fac_aux n (k + 2)
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ ⟨n, k⟩, nat.sqrt n + 2 - k)⟩]}

/-- Returns the smallest prime factor `p` of `n` such that `p^2 ∣ n`, or `none` if there is no
  such `p` (that is, `n` is squarefree). See also `squarefree_iff_min_sq_fac`. -/
def min_sq_fac (n : ℕ) : option ℕ :=
if 2 ∣ n then
  let n' := n / 2 in
  if 2 ∣ n' then some 2 else min_sq_fac_aux n' 3
else min_sq_fac_aux n 3

/-- The correctness property of the return value of `min_sq_fac`.
  * If `none`, then `n` is squarefree;
  * If `some d`, then `d` is a minimal square factor of `n` -/
def min_sq_fac_prop (n : ℕ) : option ℕ → Prop
| none := squarefree n
| (some d) := prime d ∧ d * d ∣ n ∧ ∀ p, prime p → p * p ∣ n → d ≤ p

theorem min_sq_fac_prop_div (n) {k} (pk : prime k) (dk : k ∣ n) (dkk : ¬ k * k ∣ n)
  {o} (H : min_sq_fac_prop (n / k) o) : min_sq_fac_prop n o :=
begin
  have : ∀ p, prime p → p*p ∣ n → k*(p*p) ∣ n := λ p pp dp,
    have _ := (coprime_primes pk pp).2 (λ e, by { subst e, contradiction }),
    (coprime_mul_iff_right.2 ⟨this, this⟩).mul_dvd_of_dvd_of_dvd dk dp,
  cases o with d,
  { rw [min_sq_fac_prop, squarefree_iff_prime_squarefree] at H ⊢,
    exact λ p pp dp, H p pp ((dvd_div_iff dk).2 (this _ pp dp)) },
  { obtain ⟨H1, H2, H3⟩ := H,
    simp only [dvd_div_iff dk] at H2 H3,
    exact ⟨H1, dvd_trans (dvd_mul_left _ _) H2, λ p pp dp, H3 _ pp (this _ pp dp)⟩ }
end

theorem min_sq_fac_aux_has_prop : ∀ {n : ℕ} k, 0 < n → ∀ i, k = 2*i+3 →
  (∀ m, prime m → m ∣ n → k ≤ m) → min_sq_fac_prop n (min_sq_fac_aux n k)
| n k := λ n0 i e ih, begin
  rw min_sq_fac_aux,
  by_cases h : n < k*k; simp [h],
  { refine squarefree_iff_prime_squarefree.2 (λ p pp d, _),
    have := ih p pp (dvd_trans ⟨_, rfl⟩ d),
    have := nat.mul_le_mul this this,
    exact not_le_of_lt h (le_trans this (le_of_dvd n0 d)) },
  have k2 : 2 ≤ k, { subst e, exact dec_trivial },
  have k0 : 0 < k := lt_of_lt_of_le dec_trivial k2,
  have IH : ∀ n', n' ∣ n → ¬ k ∣ n' → min_sq_fac_prop n' (n'.min_sq_fac_aux (k + 2)),
  { intros n' nd' nk,
    have hn' := le_of_dvd n0 nd',
    refine
      have nat.sqrt n' - k < nat.sqrt n + 2 - k, from
        lt_of_le_of_lt (nat.sub_le_sub_right (nat.sqrt_le_sqrt hn') _) (nat.min_fac_lemma n k h),
      @min_sq_fac_aux_has_prop n' (k+2) (pos_of_dvd_of_pos nd' n0)
        (i+1) (by simp [e, left_distrib]) (λ m m2 d, _),
    cases nat.eq_or_lt_of_le (ih m m2 (dvd_trans d nd')) with me ml,
    { subst me, contradiction },
    apply (nat.eq_or_lt_of_le ml).resolve_left, intro me,
    rw [← me, e] at d, change 2 * (i + 2) ∣ n' at d,
    have := ih _ prime_two (dvd_trans (dvd_of_mul_right_dvd d) nd'),
    rw e at this, exact absurd this dec_trivial },
  have pk : k ∣ n → prime k,
  { refine λ dk, prime_def_min_fac.2 ⟨k2, le_antisymm (min_fac_le k0) _⟩,
    exact ih _ (min_fac_prime (ne_of_gt k2)) (dvd_trans (min_fac_dvd _) dk) },
  split_ifs with dk dkk,
  { exact ⟨pk dk, (nat.dvd_div_iff dk).1 dkk, λ p pp d, ih p pp (dvd_trans ⟨_, rfl⟩ d)⟩ },
  { specialize IH (n/k) (div_dvd_of_dvd dk) dkk,
    exact min_sq_fac_prop_div _ (pk dk) dk (mt (nat.dvd_div_iff dk).2 dkk) IH },
  { exact IH n (dvd_refl _) dk }
end
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ ⟨n, k⟩, nat.sqrt n + 2 - k)⟩]}

theorem min_sq_fac_has_prop (n : ℕ) : min_sq_fac_prop n (min_sq_fac n) :=
begin
  dunfold min_sq_fac, split_ifs with d2 d4,
  { exact ⟨prime_two, (dvd_div_iff d2).1 d4, λ p pp _, pp.two_le⟩ },
  { cases nat.eq_zero_or_pos n with n0 n0, { subst n0, cases d4 dec_trivial },
    refine min_sq_fac_prop_div _ prime_two d2 (mt (dvd_div_iff d2).2 d4) _,
    refine min_sq_fac_aux_has_prop 3 (nat.div_pos (le_of_dvd n0 d2) dec_trivial) 0 rfl _,
    refine λ p pp dp, succ_le_of_lt (lt_of_le_of_ne pp.two_le _),
    rintro rfl, contradiction },
  { cases nat.eq_zero_or_pos n with n0 n0, { subst n0, cases d2 dec_trivial },
    refine min_sq_fac_aux_has_prop _ n0 0 rfl _,
    refine λ p pp dp, succ_le_of_lt (lt_of_le_of_ne pp.two_le _),
    rintro rfl, contradiction },
end

theorem min_sq_fac_prime {n d : ℕ} (h : n.min_sq_fac = some d) : prime d :=
by { have := min_sq_fac_has_prop n, rw h at this, exact this.1 }

theorem min_sq_fac_dvd {n d : ℕ} (h : n.min_sq_fac = some d) : d * d ∣ n :=
by { have := min_sq_fac_has_prop n, rw h at this, exact this.2.1 }

theorem min_sq_fac_le_of_dvd {n d : ℕ} (h : n.min_sq_fac = some d)
  {m} (m2 : 2 ≤ m) (md : m * m ∣ n) : d ≤ m :=
begin
  have := min_sq_fac_has_prop n, rw h at this,
  have fd := min_fac_dvd m,
  exact le_trans
    (this.2.2 _ (min_fac_prime $ ne_of_gt m2) (dvd_trans (mul_dvd_mul fd fd) md))
    (min_fac_le $ lt_of_lt_of_le dec_trivial m2),
end

lemma squarefree_iff_min_sq_fac {n : ℕ} :
  squarefree n ↔ n.min_sq_fac = none :=
begin
  have := min_sq_fac_has_prop n,
  split; intro H,
  { cases n.min_sq_fac with d, {refl},
    cases squarefree_iff_prime_squarefree.1 H _ this.1 this.2.1 },
  { rwa H at this }
end

instance : decidable_pred (squarefree : ℕ → Prop) :=
λ n, decidable_of_iff' _ squarefree_iff_min_sq_fac

theorem squarefree_two : squarefree 2 := by rw squarefree_iff_nodup_factors; norm_num

open unique_factorization_monoid

lemma divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0) :
  (n.divisors.filter squarefree).val =
    (unique_factorization_monoid.normalized_factors n).to_finset.powerset.val.map
      (λ x, x.val.prod) :=
begin
  rw (finset.nodup _).ext ((finset.nodup _).map_on _),
  { intro a,
    simp only [multiset.mem_filter, id.def, multiset.mem_map, finset.filter_val, ← finset.mem_def,
      mem_divisors],
    split,
    { rintro ⟨⟨an, h0⟩, hsq⟩,
      use (unique_factorization_monoid.normalized_factors a).to_finset,
      simp only [id.def, finset.mem_powerset],
      rcases an with ⟨b, rfl⟩,
      rw mul_ne_zero_iff at h0,
      rw unique_factorization_monoid.squarefree_iff_nodup_normalized_factors h0.1 at hsq,
      rw [multiset.to_finset_subset, multiset.to_finset_val, hsq.dedup, ← associated_iff_eq,
        normalized_factors_mul h0.1 h0.2],
      exact ⟨multiset.subset_of_le (multiset.le_add_right _ _), normalized_factors_prod h0.1⟩ },
    { rintro ⟨s, hs, rfl⟩,
      rw [finset.mem_powerset, ← finset.val_le_iff, multiset.to_finset_val] at hs,
      have hs0 : s.val.prod ≠ 0,
      { rw [ne.def, multiset.prod_eq_zero_iff],
        simp only [exists_prop, id.def, exists_eq_right],
        intro con,
        apply not_irreducible_zero (irreducible_of_normalized_factor 0
            (multiset.mem_dedup.1 (multiset.mem_of_le hs con))) },
      rw (normalized_factors_prod h0).symm.dvd_iff_dvd_right,
      refine ⟨⟨multiset.prod_dvd_prod_of_le (le_trans hs (multiset.dedup_le _)), h0⟩, _⟩,
      have h := unique_factorization_monoid.factors_unique irreducible_of_normalized_factor
        (λ x hx, irreducible_of_normalized_factor x (multiset.mem_of_le
          (le_trans hs (multiset.dedup_le _)) hx)) (normalized_factors_prod hs0),
      rw [associated_eq_eq, multiset.rel_eq] at h,
      rw [unique_factorization_monoid.squarefree_iff_nodup_normalized_factors hs0, h],
      apply s.nodup } },
  { intros x hx y hy h,
    rw [← finset.val_inj, ← multiset.rel_eq, ← associated_eq_eq],
    rw [← finset.mem_def, finset.mem_powerset] at hx hy,
    apply unique_factorization_monoid.factors_unique _ _ (associated_iff_eq.2 h),
    { intros z hz,
      apply irreducible_of_normalized_factor z,
      rw ← multiset.mem_to_finset,
      apply hx hz },
    { intros z hz,
      apply irreducible_of_normalized_factor z,
      rw ← multiset.mem_to_finset,
      apply hy hz } }
end

open_locale big_operators

lemma sum_divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0)
  {α : Type*} [add_comm_monoid α] {f : ℕ → α} :
  ∑ i in (n.divisors.filter squarefree), f i =
    ∑ i in (unique_factorization_monoid.normalized_factors n).to_finset.powerset, f (i.val.prod) :=
by rw [finset.sum_eq_multiset_sum, divisors_filter_squarefree h0, multiset.map_map,
    finset.sum_eq_multiset_sum]

lemma sq_mul_squarefree_of_pos {n : ℕ} (hn : 0 < n) :
  ∃ a b : ℕ, 0 < a ∧ 0 < b ∧ b ^ 2 * a = n ∧ squarefree a :=
begin
  let S := {s ∈ finset.range (n + 1) | s ∣ n ∧ ∃ x, s = x ^ 2},
  have hSne : S.nonempty,
  { use 1,
    have h1 : 0 < n ∧ ∃ (x : ℕ), 1 = x ^ 2 := ⟨hn, ⟨1, (one_pow 2).symm⟩⟩,
    simpa [S] },
  let s := finset.max' S hSne,
  have hs : s ∈ S := finset.max'_mem S hSne,
  simp only [finset.sep_def, S, finset.mem_filter, finset.mem_range] at hs,
  obtain ⟨hsn1, ⟨a, hsa⟩, ⟨b, hsb⟩⟩ := hs,
  rw hsa at hn,
  obtain ⟨hlts, hlta⟩ := canonically_ordered_comm_semiring.mul_pos.mp hn,
  rw hsb at hsa hn hlts,
  refine ⟨a, b, hlta, (pow_pos_iff zero_lt_two).mp hlts, hsa.symm, _⟩,
  rintro x ⟨y, hy⟩,
  rw nat.is_unit_iff,
  by_contra hx,
  refine lt_le_antisymm _ (finset.le_max' S ((b * x) ^ 2) _),
  { simp_rw [S, hsa, finset.sep_def, finset.mem_filter, finset.mem_range],
    refine ⟨lt_succ_iff.mpr (le_of_dvd hn _), _, ⟨b * x, rfl⟩⟩; use y; rw hy; ring },
  { convert lt_mul_of_one_lt_right hlts
      (one_lt_pow 2 x zero_lt_two (one_lt_iff_ne_zero_and_ne_one.mpr ⟨λ h, by simp * at *, hx⟩)),
    rw mul_pow },
end

lemma sq_mul_squarefree_of_pos' {n : ℕ} (h : 0 < n) :
  ∃ a b : ℕ, (b + 1) ^ 2 * (a + 1) = n ∧ squarefree (a + 1) :=
begin
  obtain ⟨a₁, b₁, ha₁, hb₁, hab₁, hab₂⟩ := sq_mul_squarefree_of_pos h,
  refine ⟨a₁.pred, b₁.pred, _, _⟩;
  simpa only [add_one, succ_pred_eq_of_pos, ha₁, hb₁],
end

lemma sq_mul_squarefree (n : ℕ) : ∃ a b : ℕ, b ^ 2 * a = n ∧ squarefree a :=
begin
  cases n,
  { exact ⟨1, 0, (by simp), squarefree_one⟩ },
  { obtain ⟨a, b, -, -, h₁, h₂⟩ := sq_mul_squarefree_of_pos (succ_pos n),
    exact ⟨a, b, h₁, h₂⟩ },
end

/-- `squarefree` is multiplicative. Note that the → direction does not require `hmn`
and generalizes to arbitrary commutative monoids. See `squarefree.of_mul_left` and
`squarefree.of_mul_right` above for auxiliary lemmas. -/
lemma squarefree_mul {m n : ℕ} (hmn : m.coprime n) :
  squarefree (m * n) ↔ squarefree m ∧ squarefree n :=
begin
  simp only [squarefree_iff_prime_squarefree, ←sq, ←forall_and_distrib],
  refine ball_congr (λ p hp, _),
  simp only [hmn.is_prime_pow_dvd_mul (hp.is_prime_pow.pow two_ne_zero), not_or_distrib],
end

end nat

/-! ### Square-free prover -/

open norm_num

namespace tactic
namespace norm_num

/-- A predicate representing partial progress in a proof of `squarefree`. -/
def squarefree_helper (n k : ℕ) : Prop :=
0 < k → (∀ m, nat.prime m → m ∣ bit1 n → bit1 k ≤ m) → squarefree (bit1 n)

lemma squarefree_bit10 (n : ℕ) (h : squarefree_helper n 1) :
  squarefree (bit0 (bit1 n)) :=
begin
  refine @nat.min_sq_fac_prop_div _ _ nat.prime_two two_dvd_bit0 _ none _,
  { rw [bit0_eq_two_mul (bit1 n), mul_dvd_mul_iff_left (@two_ne_zero ℕ _ _)],
    exact nat.not_two_dvd_bit1 _ },
  { rw [bit0_eq_two_mul, nat.mul_div_right _ (dec_trivial:0<2)],
    refine h dec_trivial (λ p pp dp, nat.succ_le_of_lt (lt_of_le_of_ne pp.two_le _)),
    rintro rfl, exact nat.not_two_dvd_bit1 _ dp }
end

lemma squarefree_bit1 (n : ℕ) (h : squarefree_helper n 1) :
  squarefree (bit1 n) :=
begin
  refine h dec_trivial (λ p pp dp, nat.succ_le_of_lt (lt_of_le_of_ne pp.two_le _)),
  rintro rfl, exact nat.not_two_dvd_bit1 _ dp
end

lemma squarefree_helper_0 {k} (k0 : 0 < k)
  {p : ℕ} (pp : nat.prime p) (h : bit1 k ≤ p) : bit1 (k + 1) ≤ p ∨ bit1 k = p :=
begin
  rcases lt_or_eq_of_le h with (hp:_+1≤_) | hp,
  { rw [bit1, bit0_eq_two_mul] at hp, change 2*(_+1) ≤ _ at hp,
    rw [bit1, bit0_eq_two_mul],
    refine or.inl (lt_of_le_of_ne hp _), unfreezingI { rintro rfl },
    exact nat.not_prime_mul dec_trivial (lt_add_of_pos_left _ k0) pp },
  { exact or.inr hp }
end

lemma squarefree_helper_1 (n k k' : ℕ) (e : k + 1 = k')
  (hk : nat.prime (bit1 k) → ¬ bit1 k ∣ bit1 n)
  (H : squarefree_helper n k') : squarefree_helper n k :=
λ k0 ih, begin
  subst e,
  refine H (nat.succ_pos _) (λ p pp dp, _),
  refine (squarefree_helper_0 k0 pp (ih p pp dp)).resolve_right (λ hp, _),
  subst hp, cases hk pp dp
end

lemma squarefree_helper_2 (n k k' c : ℕ) (e : k + 1 = k')
  (hc : bit1 n % bit1 k = c) (c0 : 0 < c)
  (h : squarefree_helper n k') : squarefree_helper n k :=
begin
  refine squarefree_helper_1 _ _ _ e (λ _, _) h,
  refine mt _ (ne_of_gt c0), intro e₁,
  rwa [← hc, ← nat.dvd_iff_mod_eq_zero],
end

lemma squarefree_helper_3 (n n' k k' c : ℕ) (e : k + 1 = k')
  (hn' : bit1 n' * bit1 k = bit1 n)
  (hc : bit1 n' % bit1 k = c) (c0 : 0 < c)
  (H : squarefree_helper n' k') : squarefree_helper n k :=
λ k0 ih, begin
  subst e,
  have k0' : 0 < bit1 k := bit1_pos (nat.zero_le _),
  have dn' : bit1 n' ∣ bit1 n := ⟨_, hn'.symm⟩,
  have dk : bit1 k ∣ bit1 n := ⟨_, ((mul_comm _ _).trans hn').symm⟩,
  have : bit1 n / bit1 k = bit1 n',
  { rw [← hn', nat.mul_div_cancel _ k0'] },
  have k2 : 2 ≤ bit1 k := nat.succ_le_succ (bit0_pos k0),
  have pk : (bit1 k).prime,
  { refine nat.prime_def_min_fac.2 ⟨k2, le_antisymm (nat.min_fac_le k0') _⟩,
    exact ih _ (nat.min_fac_prime (ne_of_gt k2)) (dvd_trans (nat.min_fac_dvd _) dk) },
  have dkk' : ¬ bit1 k ∣ bit1 n', {rw [nat.dvd_iff_mod_eq_zero, hc], exact ne_of_gt c0},
  have dkk : ¬ bit1 k * bit1 k ∣ bit1 n, {rwa [← nat.dvd_div_iff dk, this]},
  refine @nat.min_sq_fac_prop_div _ _ pk dk dkk none _,
  rw this, refine H (nat.succ_pos _) (λ p pp dp, _),
  refine (squarefree_helper_0 k0 pp (ih p pp $ dvd_trans dp dn')).resolve_right (λ e, _),
  subst e, contradiction
end

lemma squarefree_helper_4 (n k k' : ℕ) (e : bit1 k * bit1 k = k')
  (hd : bit1 n < k') : squarefree_helper n k :=
begin
  cases nat.eq_zero_or_pos n with h h,
  { subst n, exact λ _ _, squarefree_one },
  subst e,
  refine λ k0 ih, irreducible.squarefree (nat.prime_def_le_sqrt.2 ⟨bit1_lt_bit1.2 h, _⟩),
  intros m m2 hm md,
  obtain ⟨p, pp, hp⟩ := nat.exists_prime_and_dvd (ne_of_gt m2),
  have := (ih p pp (dvd_trans hp md)).trans
    (le_trans (nat.le_of_dvd (lt_of_lt_of_le dec_trivial m2) hp) hm),
  rw nat.le_sqrt at this,
  exact not_le_of_lt hd this
end

lemma not_squarefree_mul (a aa b n : ℕ) (ha : a * a = aa) (hb : aa * b = n)
  (h₁ : 1 < a) : ¬ squarefree n :=
by { rw [← hb, ← ha], exact λ H, ne_of_gt h₁ (nat.is_unit_iff.1 $ H _ ⟨_, rfl⟩) }

/-- Given `e` a natural numeral and `a : nat` with `a^2 ∣ n`, return `⊢ ¬ squarefree e`. -/
meta def prove_non_squarefree (e : expr) (n a : ℕ) : tactic expr := do
  let ea := reflect a,
  let eaa := reflect (a*a),
  c ← mk_instance_cache `(nat),
  (c, p₁) ← prove_lt_nat c `(1) ea,
  let b := n / (a*a), let eb := reflect b,
  (c, eaa, pa) ← prove_mul_nat c ea ea,
  (c, e', pb) ← prove_mul_nat c eaa eb,
  guard (e' =ₐ e),
  return $ `(@not_squarefree_mul).mk_app [ea, eaa, eb, e, pa, pb, p₁]

/-- Given `en`,`en1 := bit1 en`, `n1` the value of `en1`, `ek`,
  returns `⊢ squarefree_helper en ek`. -/
meta def prove_squarefree_aux : ∀ (ic : instance_cache) (en en1 : expr) (n1 : ℕ)
  (ek : expr) (k : ℕ), tactic expr
| ic en en1 n1 ek k := do
  let k1 := bit1 k,
  let ek1 := `(bit1:ℕ→ℕ).mk_app [ek],
  if n1 < k1*k1 then do
    (ic, ek', p₁) ← prove_mul_nat ic ek1 ek1,
    (ic, p₂) ← prove_lt_nat ic en1 ek',
    pure $ `(squarefree_helper_4).mk_app [en, ek, ek', p₁, p₂]
  else do
    let c := n1 % k1,
    let k' := k+1, let ek' := reflect k',
    (ic, p₁) ← prove_succ ic ek ek',
    if c = 0 then do
      let n1' := n1 / k1,
      let n' := n1' / 2, let en' := reflect n',
      let en1' := `(bit1:ℕ→ℕ).mk_app [en'],
      (ic, _, pn') ← prove_mul_nat ic en1' ek1,
      let c := n1' % k1,
      guard (c ≠ 0),
      (ic, ec, pc) ← prove_div_mod ic en1' ek1 tt,
      (ic, p₀) ← prove_pos ic ec,
      p₂ ← prove_squarefree_aux ic en' en1' n1' ek' k',
      pure $ `(squarefree_helper_3).mk_app [en, en', ek, ek', ec, p₁, pn', pc, p₀, p₂]
    else do
      (ic, ec, pc) ← prove_div_mod ic en1 ek1 tt,
      (ic, p₀) ← prove_pos ic ec,
      p₂ ← prove_squarefree_aux ic en en1 n1 ek' k',
      pure $ `(squarefree_helper_2).mk_app [en, ek, ek', ec, p₁, pc, p₀, p₂]

/-- Given `n > 0` a squarefree natural numeral, returns `⊢ squarefree n`. -/
meta def prove_squarefree (en : expr) (n : ℕ) : tactic expr :=
match match_numeral en with
| match_numeral_result.one := pure `(@squarefree_one ℕ _)
| match_numeral_result.bit0 en1 := match match_numeral en1 with
  | match_numeral_result.one := pure `(nat.squarefree_two)
  | match_numeral_result.bit1 en := do
    ic ← mk_instance_cache `(ℕ),
    p ← prove_squarefree_aux ic en en1 (n / 2) `(1:ℕ) 1,
    pure $ `(squarefree_bit10).mk_app [en, p]
  | _ := failed
  end
| match_numeral_result.bit1 en' := do
  ic ← mk_instance_cache `(ℕ),
  p ← prove_squarefree_aux ic en' en n `(1:ℕ) 1,
  pure $ `(squarefree_bit1).mk_app [en', p]
| _ := failed
end

/-- Evaluates the `prime` and `min_fac` functions. -/
@[norm_num] meta def eval_squarefree : expr → tactic (expr × expr)
| `(squarefree (%%e : ℕ)) := do
  n ← e.to_nat,
  match n with
  | 0 := false_intro `(@not_squarefree_zero ℕ _ _)
  | 1 := true_intro `(@squarefree_one ℕ _)
  | _ := match n.min_sq_fac with
    | some d := prove_non_squarefree e n d >>= false_intro
    | none := prove_squarefree e n >>= true_intro
    end
  end
| _ := failed

end norm_num
end tactic


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

/-!
# GCD and LCM operations on multisets

## Main definitions

- `multiset.gcd` - the greatest common denominator of a `multiset` of elements of a `gcd_monoid`
- `multiset.lcm` - the least common multiple of a `multiset` of elements of a `gcd_monoid`

## Implementation notes

TODO: simplify with a tactic and `data.multiset.lattice`

## Tags

multiset, gcd
-/

namespace multiset
variables {α : Type*} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α]

/-! ### lcm -/
section lcm

/-- Least common multiple of a multiset -/
def lcm (s : multiset α) : α := s.fold gcd_monoid.lcm 1

@[simp] lemma lcm_zero : (0 : multiset α).lcm = 1 :=
fold_zero _ _

@[simp] lemma lcm_cons (a : α) (s : multiset α) :
  (a ::ₘ s).lcm = gcd_monoid.lcm a s.lcm :=
fold_cons_left _ _ _ _

@[simp] lemma lcm_singleton {a : α} : (a ::ₘ 0).lcm = normalize a := by simp

@[simp] lemma lcm_add (s₁ s₂ : multiset α) : (s₁ + s₂).lcm = gcd_monoid.lcm s₁.lcm s₂.lcm :=
eq.trans (by simp [lcm]) (fold_add _ _ _ _ _)

lemma lcm_dvd {s : multiset α} {a : α} : s.lcm ∣ a ↔ (∀ b ∈ s, b ∣ a) :=
multiset.induction_on s (by simp)
  (by simp [or_imp_distrib, forall_and_distrib, lcm_dvd_iff] {contextual := tt})

lemma dvd_lcm {s : multiset α} {a : α} (h : a ∈ s) : a ∣ s.lcm :=
lcm_dvd.1 (dvd_refl _) _ h

lemma lcm_mono {s₁ s₂ : multiset α} (h : s₁ ⊆ s₂) : s₁.lcm ∣ s₂.lcm :=
lcm_dvd.2 $ assume b hb, dvd_lcm (h hb)

@[simp] lemma normalize_lcm (s : multiset α) : normalize (s.lcm) = s.lcm :=
multiset.induction_on s (by simp) $ λ a s IH, by simp

variables [decidable_eq α]

@[simp] lemma lcm_erase_dup (s : multiset α) : (erase_dup s).lcm = s.lcm :=
multiset.induction_on s (by simp) $ λ a s IH, begin
  by_cases a ∈ s; simp [IH, h],
  unfold lcm,
  rw [← cons_erase h, fold_cons_left, ← lcm_assoc, lcm_same],
  apply lcm_eq_of_associated_left associated_normalize,
end

@[simp] lemma lcm_ndunion (s₁ s₂ : multiset α) :
  (ndunion s₁ s₂).lcm = gcd_monoid.lcm s₁.lcm s₂.lcm :=
by { rw [← lcm_erase_dup, erase_dup_ext.2, lcm_erase_dup, lcm_add], simp }

@[simp] lemma lcm_union (s₁ s₂ : multiset α) :
  (s₁ ∪ s₂).lcm = gcd_monoid.lcm s₁.lcm s₂.lcm :=
by { rw [← lcm_erase_dup, erase_dup_ext.2, lcm_erase_dup, lcm_add], simp }

@[simp] lemma lcm_ndinsert (a : α) (s : multiset α) :
  (ndinsert a s).lcm = gcd_monoid.lcm a s.lcm :=
by { rw [← lcm_erase_dup, erase_dup_ext.2, lcm_erase_dup, lcm_cons], simp }

end lcm

/-! ### gcd -/
section gcd

/-- Greatest common divisor of a multiset -/
def gcd (s : multiset α) : α := s.fold gcd_monoid.gcd 0

@[simp] lemma gcd_zero : (0 : multiset α).gcd = 0 :=
fold_zero _ _

@[simp] lemma gcd_cons (a : α) (s : multiset α) :
  (a ::ₘ s).gcd = gcd_monoid.gcd a s.gcd :=
fold_cons_left _ _ _ _

@[simp] lemma gcd_singleton {a : α} : (a ::ₘ 0).gcd = normalize a := by simp

@[simp] lemma gcd_add (s₁ s₂ : multiset α) : (s₁ + s₂).gcd = gcd_monoid.gcd s₁.gcd s₂.gcd :=
eq.trans (by simp [gcd]) (fold_add _ _ _ _ _)

lemma dvd_gcd {s : multiset α} {a : α} : a ∣ s.gcd ↔ (∀ b ∈ s, a ∣ b) :=
multiset.induction_on s (by simp)
  (by simp [or_imp_distrib, forall_and_distrib, dvd_gcd_iff] {contextual := tt})

lemma gcd_dvd {s : multiset α} {a : α} (h : a ∈ s) : s.gcd ∣ a :=
dvd_gcd.1 (dvd_refl _) _ h

lemma gcd_mono {s₁ s₂ : multiset α} (h : s₁ ⊆ s₂) : s₂.gcd ∣ s₁.gcd :=
dvd_gcd.2 $ assume b hb, gcd_dvd (h hb)

@[simp] lemma normalize_gcd (s : multiset α) : normalize (s.gcd) = s.gcd :=
multiset.induction_on s (by simp) $ λ a s IH, by simp

theorem gcd_eq_zero_iff (s : multiset α) : s.gcd = 0 ↔ ∀ (x : α), x ∈ s → x = 0 :=
begin
  split,
  { intros h x hx,
    apply eq_zero_of_zero_dvd,
    rw ← h,
    apply gcd_dvd hx },
  { apply s.induction_on,
    { simp },
    intros a s sgcd h,
    simp [h a (mem_cons_self a s), sgcd (λ x hx, h x (mem_cons_of_mem hx))] }
end

variables [decidable_eq α]

@[simp] lemma gcd_erase_dup (s : multiset α) : (erase_dup s).gcd = s.gcd :=
multiset.induction_on s (by simp) $ λ a s IH, begin
  by_cases a ∈ s; simp [IH, h],
  unfold gcd,
  rw [← cons_erase h, fold_cons_left, ← gcd_assoc, gcd_same],
  apply gcd_eq_of_associated_left associated_normalize,
end

@[simp] lemma gcd_ndunion (s₁ s₂ : multiset α) :
  (ndunion s₁ s₂).gcd = gcd_monoid.gcd s₁.gcd s₂.gcd :=
by { rw [← gcd_erase_dup, erase_dup_ext.2, gcd_erase_dup, gcd_add], simp }

@[simp] lemma gcd_union (s₁ s₂ : multiset α) :
  (s₁ ∪ s₂).gcd = gcd_monoid.gcd s₁.gcd s₂.gcd :=
by { rw [← gcd_erase_dup, erase_dup_ext.2, gcd_erase_dup, gcd_add], simp }

@[simp] lemma gcd_ndinsert (a : α) (s : multiset α) :
  (ndinsert a s).gcd = gcd_monoid.gcd a s.gcd :=
by { rw [← gcd_erase_dup, erase_dup_ext.2, gcd_erase_dup, gcd_cons], simp }

end gcd

end multiset


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.deriv
import linear_algebra.affine_space.slope

/-!
# Slope of a differentiable function

Given a function `f : 𝕜 → E` from a nondiscrete normed field to a normed space over this field,
`dslope f a b` is defined as `slope f a b = (b - a)⁻¹ • (f b - f a)` for `a ≠ b` and as `deriv f a`
for `a = b`.

In this file we define `dslope` and prove some basic lemmas about its continuity and
differentiability.
-/

open_locale classical topological_space filter
open function set filter

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

/-- `dslope f a b` is defined as `slope f a b = (b - a)⁻¹ • (f b - f a)` for `a ≠ b` and
`deriv f a` for `a = b`. -/
noncomputable def dslope (f : 𝕜 → E) (a : 𝕜) : 𝕜 → E := update (slope f a) a (deriv f a)

@[simp] lemma dslope_same (f : 𝕜 → E) (a : 𝕜) : dslope f a a = deriv f a := update_same _ _ _

variables {f : 𝕜 → E} {a b : 𝕜} {s : set 𝕜}

lemma dslope_of_ne (f : 𝕜 → E) (h : b ≠ a) : dslope f a b = slope f a b :=
update_noteq h _ _

lemma continuous_linear_map.dslope_comp {F : Type*} [normed_group F] [normed_space 𝕜 F]
  (f : E →L[𝕜] F) (g : 𝕜 → E) (a b : 𝕜) (H : a = b → differentiable_at 𝕜 g a) :
  dslope (f ∘ g) a b = f (dslope g a b) :=
begin
  rcases eq_or_ne b a with rfl|hne,
  { simp only [dslope_same],
    exact (f.has_fderiv_at.comp_has_deriv_at b (H rfl).has_deriv_at).deriv },
  { simpa only [dslope_of_ne _ hne] using f.to_linear_map.slope_comp g a b }
end

lemma eq_on_dslope_slope (f : 𝕜 → E) (a : 𝕜) : eq_on (dslope f a) (slope f a) {a}ᶜ :=
λ b, dslope_of_ne f

lemma dslope_eventually_eq_slope_of_ne (f : 𝕜 → E) (h : b ≠ a) : dslope f a =ᶠ[𝓝 b] slope f a :=
(eq_on_dslope_slope f a).eventually_eq_of_mem (is_open_ne.mem_nhds h)

lemma dslope_eventually_eq_slope_punctured_nhds (f : 𝕜 → E) : dslope f a =ᶠ[𝓝[≠] a] slope f a :=
(eq_on_dslope_slope f a).eventually_eq_of_mem self_mem_nhds_within

@[simp] lemma sub_smul_dslope (f : 𝕜 → E) (a b : 𝕜) : (b - a) • dslope f a b = f b - f a :=
by rcases eq_or_ne b a with rfl | hne; simp [dslope_of_ne, *]

lemma dslope_sub_smul_of_ne (f : 𝕜 → E) (h : b ≠ a) : dslope (λ x, (x - a) • f x) a b = f b :=
by rw [dslope_of_ne _ h, slope_sub_smul _ h.symm]

lemma eq_on_dslope_sub_smul (f : 𝕜 → E) (a : 𝕜) : eq_on (dslope (λ x, (x - a) • f x) a) f {a}ᶜ :=
λ b, dslope_sub_smul_of_ne f

lemma dslope_sub_smul [decidable_eq 𝕜] (f : 𝕜 → E) (a : 𝕜) :
  dslope (λ x, (x - a) • f x) a = update f a (deriv (λ x, (x - a) • f x) a) :=
eq_update_iff.2 ⟨dslope_same _ _, eq_on_dslope_sub_smul f a⟩

@[simp] lemma continuous_at_dslope_same : continuous_at (dslope f a) a ↔ differentiable_at 𝕜 f a :=
by simp only [dslope, continuous_at_update_same, ← has_deriv_at_deriv_iff,
  has_deriv_at_iff_tendsto_slope]

lemma continuous_within_at.of_dslope (h : continuous_within_at (dslope f a) s b) :
  continuous_within_at f s b :=
have continuous_within_at (λ x, (x - a) • dslope f a x + f a) s b,
  from ((continuous_within_at_id.sub continuous_within_at_const).smul h).add
    continuous_within_at_const,
by simpa only [sub_smul_dslope, sub_add_cancel] using this

lemma continuous_at.of_dslope (h : continuous_at (dslope f a) b) : continuous_at f b :=
(continuous_within_at_univ _ _).1 h.continuous_within_at.of_dslope

lemma continuous_on.of_dslope (h : continuous_on (dslope f a) s) : continuous_on f s :=
λ x hx, (h x hx).of_dslope

lemma continuous_within_at_dslope_of_ne (h : b ≠ a) :
  continuous_within_at (dslope f a) s b ↔ continuous_within_at f s b :=
begin
  refine ⟨continuous_within_at.of_dslope, λ hc, _⟩,
  simp only [dslope, continuous_within_at_update_of_ne h],
  exact ((continuous_within_at_id.sub continuous_within_at_const).inv₀
      (sub_ne_zero.2 h)).smul (hc.sub continuous_within_at_const)
end

lemma continuous_at_dslope_of_ne (h : b ≠ a) : continuous_at (dslope f a) b ↔ continuous_at f b :=
by simp only [← continuous_within_at_univ, continuous_within_at_dslope_of_ne h]

lemma continuous_on_dslope (h : s ∈ 𝓝 a) :
  continuous_on (dslope f a) s ↔ continuous_on f s ∧ differentiable_at 𝕜 f a :=
begin
  refine ⟨λ hc, ⟨hc.of_dslope, continuous_at_dslope_same.1 $ hc.continuous_at h⟩, _⟩,
  rintro ⟨hc, hd⟩ x hx,
  rcases eq_or_ne x a with rfl | hne,
  exacts [(continuous_at_dslope_same.2 hd).continuous_within_at,
    (continuous_within_at_dslope_of_ne hne).2 (hc x hx)]
end

lemma differentiable_within_at.of_dslope (h : differentiable_within_at 𝕜 (dslope f a) s b) :
  differentiable_within_at 𝕜 f s b :=
by simpa only [id, sub_smul_dslope f a, sub_add_cancel]
  using ((differentiable_within_at_id.sub_const a).smul h).add_const (f a)

lemma differentiable_at.of_dslope (h : differentiable_at 𝕜 (dslope f a) b) :
  differentiable_at 𝕜 f b :=
differentiable_within_at_univ.1 h.differentiable_within_at.of_dslope

lemma differentiable_on.of_dslope (h : differentiable_on 𝕜 (dslope f a) s) :
  differentiable_on 𝕜 f s :=
λ x hx, (h x hx).of_dslope

lemma differentiable_within_at_dslope_of_ne (h : b ≠ a) :
  differentiable_within_at 𝕜 (dslope f a) s b ↔ differentiable_within_at 𝕜 f s b :=
begin
  refine ⟨differentiable_within_at.of_dslope, λ hd, _⟩,
  refine (((differentiable_within_at_id.sub_const a).inv
    (sub_ne_zero.2 h)).smul (hd.sub_const (f a))).congr_of_eventually_eq _ (dslope_of_ne _ h),
  refine (eq_on_dslope_slope _ _).eventually_eq_of_mem _,
  exact mem_nhds_within_of_mem_nhds (is_open_ne.mem_nhds h)
end

lemma differentiable_on_dslope_of_nmem (h : a ∉ s) :
  differentiable_on 𝕜 (dslope f a) s ↔ differentiable_on 𝕜 f s :=
forall_congr $ λ x, forall_congr $ λ hx, differentiable_within_at_dslope_of_ne $
  ne_of_mem_of_not_mem hx h

lemma differentiable_at_dslope_of_ne (h : b ≠ a) :
  differentiable_at 𝕜 (dslope f a) b ↔ differentiable_at 𝕜 f b :=
by simp only [← differentiable_within_at_univ,
  differentiable_within_at_dslope_of_ne h]


-- LEAN (*
definition prefix_sum : ℕ → list ℕ → list ℕ
| sum [] := [sum]
| sum (head :: tail) := sum :: (prefix_sum (sum + head) tail).

definition plus_list : list ℕ → list ℕ → list ℕ
| [] _ := []
| _ [] := []
| (h1 :: t1) (h2 :: t2) := (h1 + h2) :: plus_list t1 t2.

example : ∀ l1 l2 : list ℕ,
    prefix_sum 0 (plus_list l1 l2) = plus_list (prefix_sum 0 l1) (prefix_sum 0 l2) :=
begin
  have plus_list_nil_l : ∀ l : list ℕ,
      plus_list [] l = [] :=
    begin
      intros l,
      cases l,
      unfold plus_list,
      unfold plus_list,
    end,
  have plus_list_nil_r : ∀ l : list ℕ,
      plus_list l [] = [] :=
    begin
      intros l,
      cases l,
      unfold plus_list,
      unfold plus_list,
    end,
  have generic_lemma : ∀ l1 l2 : list ℕ, ∀ n m,
    prefix_sum (n + m) (plus_list l1 l2) = plus_list (prefix_sum n l1) (prefix_sum m l2) :=
    begin
      intros l1,
      induction l1; intros l2,
        unfold prefix_sum,
        rewrite plus_list_nil_l,
        unfold prefix_sum,
        cases l2; intros n m,
          unfold prefix_sum,
          by unfold plus_list,
        unfold prefix_sum,
        unfold plus_list,
        by rewrite plus_list_nil_l,
      intros n m,
      unfold prefix_sum,
      cases l2,
        unfold prefix_sum,
        unfold plus_list,
        unfold prefix_sum,
        by rewrite plus_list_nil_r,
      unfold plus_list,
      unfold prefix_sum,
      unfold plus_list,
      simp,
      rw [←l1_ih l2_tl (l1_hd + n) (m + l2_hd)],
      by rw [add_assoc],
  end,
  intros l1 l2,
  by rewrite [←generic_lemma],
end.
/- Coq *)
unfold task.
assert (plus_list_nil_r : forall l,
  plus_list l nil = nil). {
  intro l; case l; reflexivity.
}
assert (generic : forall l1 l2, forall n m,
  prefix_sum (n + m) (plus_list l1 l2) =
  plus_list (prefix_sum n l1) (prefix_sum m l2)). {
  intro l1. induction l1.
    intro l2. induction l2; intros n m; reflexivity.
  intro l2. case l2.
    intros n m.
    simpl.
    rewrite plus_list_nil_r.
    reflexivity.
  intros x l2' n m.
  simpl.
  rewrite <- IHl1.
  rewrite PeanoNat.Nat.add_shuffle1.
  reflexivity.
}
intros l1 l2.
rewrite <- generic.
reflexivity. (* -/ -- *)