/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.metric_space.baire
import analysis.normed_space.operator_norm
import analysis.normed_space.affine_isometry

/-!
# Banach open mapping theorem

This file contains the Banach open mapping theorem, i.e., the fact that a bijective
bounded linear map between Banach spaces has a bounded inverse.
-/

open function metric set filter finset
open_locale classical topological_space big_operators nnreal

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{F : Type*} [normed_group F] [normed_space 𝕜 F]
(f : E →L[𝕜] F)
include 𝕜

namespace continuous_linear_map

/-- A (possibly nonlinear) right inverse to a continuous linear map, which doesn't have to be
linear itself but which satisfies a bound `∥inverse x∥ ≤ C * ∥x∥`. A surjective continuous linear
map doesn't always have a continuous linear right inverse, but it always has a nonlinear inverse
in this sense, by Banach's open mapping theorem. -/
structure nonlinear_right_inverse :=
(to_fun : F → E)
(nnnorm : ℝ≥0)
(bound' : ∀ y, ∥to_fun y∥ ≤ nnnorm * ∥y∥)
(right_inv' : ∀ y, f (to_fun y) = y)

instance : has_coe_to_fun (nonlinear_right_inverse f) (λ _, F → E) := ⟨λ fsymm, fsymm.to_fun⟩

@[simp] lemma nonlinear_right_inverse.right_inv {f : E →L[𝕜] F} (fsymm : nonlinear_right_inverse f)
  (y : F) : f (fsymm y) = y :=
fsymm.right_inv' y

lemma nonlinear_right_inverse.bound {f : E →L[𝕜] F} (fsymm : nonlinear_right_inverse f) (y : F) :
  ∥fsymm y∥ ≤ fsymm.nnnorm * ∥y∥ :=
fsymm.bound' y

end continuous_linear_map

/-- Given a continuous linear equivalence, the inverse is in particular an instance of
`nonlinear_right_inverse` (which turns out to be linear). -/
noncomputable def continuous_linear_equiv.to_nonlinear_right_inverse (f : E ≃L[𝕜] F) :
  continuous_linear_map.nonlinear_right_inverse (f : E →L[𝕜] F) :=
{ to_fun := f.inv_fun,
  nnnorm := ∥(f.symm : F →L[𝕜] E)∥₊,
  bound' := λ y, continuous_linear_map.le_op_norm (f.symm : F →L[𝕜] E) _,
  right_inv' := f.apply_symm_apply }

noncomputable instance (f : E ≃L[𝕜] F) :
  inhabited (continuous_linear_map.nonlinear_right_inverse (f : E →L[𝕜] F)) :=
⟨f.to_nonlinear_right_inverse⟩

/-! ### Proof of the Banach open mapping theorem -/

variable [complete_space F]

namespace continuous_linear_map
/--
First step of the proof of the Banach open mapping theorem (using completeness of `F`):
by Baire's theorem, there exists a ball in `E` whose image closure has nonempty interior.
Rescaling everything, it follows that any `y ∈ F` is arbitrarily well approached by
images of elements of norm at most `C * ∥y∥`.
For further use, we will only need such an element whose image
is within distance `∥y∥/2` of `y`, to apply an iterative process. -/
lemma exists_approx_preimage_norm_le (surj : surjective f) :
  ∃C ≥ 0, ∀y, ∃x, dist (f x) y ≤ 1/2 * ∥y∥ ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  have A : (⋃n:ℕ, closure (f '' (ball 0 n))) = univ,
  { refine subset.antisymm (subset_univ _) (λy hy, _),
    rcases surj y with ⟨x, hx⟩,
    rcases exists_nat_gt (∥x∥) with ⟨n, hn⟩,
    refine mem_Union.2 ⟨n, subset_closure _⟩,
    refine (mem_image _ _ _).2 ⟨x, ⟨_, hx⟩⟩,
    rwa [mem_ball, dist_eq_norm, sub_zero] },
  have : ∃ (n : ℕ) x, x ∈ interior (closure (f '' (ball 0 n))) :=
    nonempty_interior_of_Union_of_closed (λn, is_closed_closure) A,
  simp only [mem_interior_iff_mem_nhds, metric.mem_nhds_iff] at this,
  rcases this with ⟨n, a, ε, ⟨εpos, H⟩⟩,
  rcases normed_field.exists_one_lt_norm 𝕜 with ⟨c, hc⟩,
  refine ⟨(ε/2)⁻¹ * ∥c∥ * 2 * n, _, λy, _⟩,
  { refine mul_nonneg (mul_nonneg (mul_nonneg _ (norm_nonneg _)) (by norm_num)) _,
    exacts [inv_nonneg.2 (div_nonneg (le_of_lt εpos) (by norm_num)), n.cast_nonneg] },
  { by_cases hy : y = 0,
    { use 0, simp [hy] },
    { rcases rescale_to_shell hc (half_pos εpos) hy with ⟨d, hd, ydlt, leyd, dinv⟩,
      let δ := ∥d∥ * ∥y∥/4,
      have δpos : 0 < δ :=
        div_pos (mul_pos (norm_pos_iff.2 hd) (norm_pos_iff.2 hy)) (by norm_num),
      have : a + d • y ∈ ball a ε,
        by simp [dist_eq_norm, lt_of_le_of_lt ydlt.le (half_lt_self εpos)],
      rcases metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₁, z₁im, h₁⟩,
      rcases (mem_image _ _ _).1 z₁im with ⟨x₁, hx₁, xz₁⟩,
      rw ← xz₁ at h₁,
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₁,
      have : a ∈ ball a ε, by { simp, exact εpos },
      rcases metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₂, z₂im, h₂⟩,
      rcases (mem_image _ _ _).1 z₂im with ⟨x₂, hx₂, xz₂⟩,
      rw ← xz₂ at h₂,
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₂,
      let x := x₁ - x₂,
      have I : ∥f x - d • y∥ ≤ 2 * δ := calc
        ∥f x - d • y∥ = ∥f x₁ - (a + d • y) - (f x₂ - a)∥ :
          by { congr' 1, simp only [x, f.map_sub], abel }
        ... ≤ ∥f x₁ - (a + d • y)∥ + ∥f x₂ - a∥ :
          norm_sub_le _ _
        ... ≤ δ + δ : begin
            apply add_le_add,
            { rw [← dist_eq_norm, dist_comm], exact le_of_lt h₁ },
            { rw [← dist_eq_norm, dist_comm], exact le_of_lt h₂ }
          end
        ... = 2 * δ : (two_mul _).symm,
      have J : ∥f (d⁻¹ • x) - y∥ ≤ 1/2 * ∥y∥ := calc
        ∥f (d⁻¹ • x) - y∥ = ∥d⁻¹ • f x - (d⁻¹ * d) • y∥ :
          by rwa [f.map_smul _, inv_mul_cancel, one_smul]
        ... = ∥d⁻¹ • (f x - d • y)∥ : by rw [mul_smul, smul_sub]
        ... = ∥d∥⁻¹ * ∥f x - d • y∥ : by rw [norm_smul, norm_inv]
        ... ≤ ∥d∥⁻¹ * (2 * δ) : begin
            apply mul_le_mul_of_nonneg_left I,
            rw inv_nonneg,
            exact norm_nonneg _
          end
        ... = (∥d∥⁻¹ * ∥d∥) * ∥y∥ /2 : by { simp only [δ], ring }
        ... = ∥y∥/2 : by { rw [inv_mul_cancel, one_mul],  simp [norm_eq_zero, hd] }
        ... = (1/2) * ∥y∥ : by ring,
      rw ← dist_eq_norm at J,
      have K : ∥d⁻¹ • x∥ ≤ (ε / 2)⁻¹ * ∥c∥ * 2 * ↑n * ∥y∥ := calc
        ∥d⁻¹ • x∥ = ∥d∥⁻¹ * ∥x₁ - x₂∥ : by rw [norm_smul, norm_inv]
        ... ≤ ((ε / 2)⁻¹ * ∥c∥ * ∥y∥) * (n + n) : begin
            refine mul_le_mul dinv _ (norm_nonneg _) _,
            { exact le_trans (norm_sub_le _ _) (add_le_add (le_of_lt hx₁) (le_of_lt hx₂)) },
            { apply mul_nonneg (mul_nonneg _ (norm_nonneg _)) (norm_nonneg _),
              exact inv_nonneg.2 (le_of_lt (half_pos εpos)) }
          end
        ... = (ε / 2)⁻¹ * ∥c∥ * 2 * ↑n * ∥y∥ : by ring,
      exact ⟨d⁻¹ • x, J, K⟩ } },
end

variable [complete_space E]

/-- The Banach open mapping theorem: if a bounded linear map between Banach spaces is onto, then
any point has a preimage with controlled norm. -/
theorem exists_preimage_norm_le (surj : surjective f) :
  ∃C > 0, ∀y, ∃x, f x = y ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  obtain ⟨C, C0, hC⟩ := exists_approx_preimage_norm_le f surj,
  /- Second step of the proof: starting from `y`, we want an exact preimage of `y`. Let `g y` be
  the approximate preimage of `y` given by the first step, and `h y = y - f(g y)` the part that
  has no preimage yet. We will iterate this process, taking the approximate preimage of `h y`,
  leaving only `h^2 y` without preimage yet, and so on. Let `u n` be the approximate preimage
  of `h^n y`. Then `u` is a converging series, and by design the sum of the series is a
  preimage of `y`. This uses completeness of `E`. -/
  choose g hg using hC,
  let h := λy, y - f (g y),
  have hle : ∀y, ∥h y∥ ≤ (1/2) * ∥y∥,
  { assume y,
    rw [← dist_eq_norm, dist_comm],
    exact (hg y).1 },
  refine ⟨2 * C + 1, by linarith, λy, _⟩,
  have hnle : ∀n:ℕ, ∥(h^[n]) y∥ ≤ (1/2)^n * ∥y∥,
  { assume n,
    induction n with n IH,
    { simp only [one_div, nat.nat_zero_eq_zero, one_mul, iterate_zero_apply,
        pow_zero] },
    { rw [iterate_succ'],
      apply le_trans (hle _) _,
      rw [pow_succ, mul_assoc],
      apply mul_le_mul_of_nonneg_left IH,
      norm_num } },
  let u := λn, g((h^[n]) y),
  have ule : ∀n, ∥u n∥ ≤ (1/2)^n * (C * ∥y∥),
  { assume n,
    apply le_trans (hg _).2 _,
    calc C * ∥(h^[n]) y∥ ≤ C * ((1/2)^n * ∥y∥) : mul_le_mul_of_nonneg_left (hnle n) C0
         ... = (1 / 2) ^ n * (C * ∥y∥) : by ring },
  have sNu : summable (λn, ∥u n∥),
  { refine summable_of_nonneg_of_le (λn, norm_nonneg _) ule _,
    exact summable.mul_right _ (summable_geometric_of_lt_1 (by norm_num) (by norm_num)) },
  have su : summable u := summable_of_summable_norm sNu,
  let x := tsum u,
  have x_ineq : ∥x∥ ≤ (2 * C + 1) * ∥y∥ := calc
    ∥x∥ ≤ ∑'n, ∥u n∥ : norm_tsum_le_tsum_norm sNu
    ... ≤ ∑'n, (1/2)^n * (C * ∥y∥) :
      tsum_le_tsum ule sNu (summable.mul_right _ summable_geometric_two)
    ... = (∑'n, (1/2)^n) * (C * ∥y∥) : tsum_mul_right
    ... = 2 * C * ∥y∥ : by rw [tsum_geometric_two, mul_assoc]
    ... ≤ 2 * C * ∥y∥ + ∥y∥ : le_add_of_nonneg_right (norm_nonneg y)
    ... = (2 * C + 1) * ∥y∥ : by ring,
  have fsumeq : ∀n:ℕ, f (∑ i in finset.range n, u i) = y - (h^[n]) y,
  { assume n,
    induction n with n IH,
    { simp [f.map_zero] },
    { rw [sum_range_succ, f.map_add, IH, iterate_succ', sub_add] } },
  have : tendsto (λn, ∑ i in finset.range n, u i) at_top (𝓝 x) :=
    su.has_sum.tendsto_sum_nat,
  have L₁ : tendsto (λn, f (∑ i in finset.range n, u i)) at_top (𝓝 (f x)) :=
    (f.continuous.tendsto _).comp this,
  simp only [fsumeq] at L₁,
  have L₂ : tendsto (λn, y - (h^[n]) y) at_top (𝓝 (y - 0)),
  { refine tendsto_const_nhds.sub _,
    rw tendsto_iff_norm_tendsto_zero,
    simp only [sub_zero],
    refine squeeze_zero (λ_, norm_nonneg _) hnle _,
    rw [← zero_mul ∥y∥],
    refine (tendsto_pow_at_top_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds; norm_num },
  have feq : f x = y - 0 := tendsto_nhds_unique L₁ L₂,
  rw sub_zero at feq,
  exact ⟨x, feq, x_ineq⟩
end

/-- The Banach open mapping theorem: a surjective bounded linear map between Banach spaces is
open. -/
protected theorem is_open_map (surj : surjective f) : is_open_map f :=
begin
  assume s hs,
  rcases exists_preimage_norm_le f surj with ⟨C, Cpos, hC⟩,
  refine is_open_iff.2 (λy yfs, _),
  rcases mem_image_iff_bex.1 yfs with ⟨x, xs, fxy⟩,
  rcases is_open_iff.1 hs x xs with ⟨ε, εpos, hε⟩,
  refine ⟨ε/C, div_pos εpos Cpos, λz hz, _⟩,
  rcases hC (z-y) with ⟨w, wim, wnorm⟩,
  have : f (x + w) = z, by { rw [f.map_add, wim, fxy, add_sub_cancel'_right] },
  rw ← this,
  have : x + w ∈ ball x ε := calc
    dist (x+w) x = ∥w∥ : by { rw dist_eq_norm, simp }
    ... ≤ C * ∥z - y∥ : wnorm
    ... < C * (ε/C) : begin
        apply mul_lt_mul_of_pos_left _ Cpos,
        rwa [mem_ball, dist_eq_norm] at hz,
      end
    ... = ε : mul_div_cancel' _ (ne_of_gt Cpos),
  exact set.mem_image_of_mem _ (hε this)
end

protected theorem quotient_map (surj : surjective f) : quotient_map f :=
(f.is_open_map surj).to_quotient_map f.continuous surj

lemma _root_.affine_map.is_open_map {P Q : Type*}
  [metric_space P] [normed_add_torsor E P] [metric_space Q] [normed_add_torsor F Q]
  (f : P →ᵃ[𝕜] Q) (hf : continuous f) (surj : surjective f) :
  is_open_map f :=
affine_map.is_open_map_linear_iff.mp $ continuous_linear_map.is_open_map
  { cont := affine_map.continuous_linear_iff.mpr hf, .. f.linear }
  (f.surjective_iff_linear_surjective.mpr surj)

/-! ### Applications of the Banach open mapping theorem -/

lemma interior_preimage (hsurj : surjective f) (s : set F) :
  interior (f ⁻¹' s) = f ⁻¹' (interior s) :=
((f.is_open_map hsurj).preimage_interior_eq_interior_preimage f.continuous s).symm

lemma closure_preimage (hsurj : surjective f) (s : set F) :
  closure (f ⁻¹' s) = f ⁻¹' (closure s) :=
((f.is_open_map hsurj).preimage_closure_eq_closure_preimage f.continuous s).symm

lemma frontier_preimage (hsurj : surjective f) (s : set F) :
  frontier (f ⁻¹' s) = f ⁻¹' (frontier s) :=
((f.is_open_map hsurj).preimage_frontier_eq_frontier_preimage f.continuous s).symm

lemma exists_nonlinear_right_inverse_of_surjective (f : E →L[𝕜] F) (hsurj : f.range = ⊤) :
  ∃ (fsymm : nonlinear_right_inverse f), 0 < fsymm.nnnorm :=
begin
  choose C hC fsymm h using exists_preimage_norm_le _ (linear_map.range_eq_top.mp hsurj),
  use { to_fun := fsymm,
        nnnorm := ⟨C, hC.lt.le⟩,
        bound' := λ y, (h y).2,
        right_inv' := λ y, (h y).1 },
  exact hC
end

/-- A surjective continuous linear map between Banach spaces admits a (possibly nonlinear)
controlled right inverse. In general, it is not possible to ensure that such a right inverse
is linear (take for instance the map from `E` to `E/F` where `F` is a closed subspace of `E`
without a closed complement. Then it doesn't have a continuous linear right inverse.) -/
@[irreducible] noncomputable def nonlinear_right_inverse_of_surjective
  (f : E →L[𝕜] F) (hsurj : f.range = ⊤) : nonlinear_right_inverse f :=
classical.some (exists_nonlinear_right_inverse_of_surjective f hsurj)

lemma nonlinear_right_inverse_of_surjective_nnnorm_pos (f : E →L[𝕜] F) (hsurj : f.range = ⊤) :
  0 < (nonlinear_right_inverse_of_surjective f hsurj).nnnorm :=
begin
  rw nonlinear_right_inverse_of_surjective,
  exact classical.some_spec (exists_nonlinear_right_inverse_of_surjective f hsurj)
end

end continuous_linear_map

namespace linear_equiv

variables [complete_space E]

/-- If a bounded linear map is a bijection, then its inverse is also a bounded linear map. -/
@[continuity]
theorem continuous_symm (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  continuous e.symm :=
begin
  rw continuous_def,
  intros s hs,
  rw [← e.image_eq_preimage],
  rw [← e.coe_coe] at h ⊢,
  exact continuous_linear_map.is_open_map ⟨↑e, h⟩ e.surjective s hs
end

/-- Associating to a linear equivalence between Banach spaces a continuous linear equivalence when
the direct map is continuous, thanks to the Banach open mapping theorem that ensures that the
inverse map is also continuous. -/
def to_continuous_linear_equiv_of_continuous (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  E ≃L[𝕜] F :=
{ continuous_to_fun := h,
  continuous_inv_fun := e.continuous_symm h,
  ..e }

@[simp] lemma coe_fn_to_continuous_linear_equiv_of_continuous (e : E ≃ₗ[𝕜] F) (h : continuous e) :
  ⇑(e.to_continuous_linear_equiv_of_continuous h) = e := rfl

@[simp] lemma coe_fn_to_continuous_linear_equiv_of_continuous_symm (e : E ≃ₗ[𝕜] F)
  (h : continuous e) :
  ⇑(e.to_continuous_linear_equiv_of_continuous h).symm = e.symm := rfl

end linear_equiv

namespace continuous_linear_equiv

variables [complete_space E]

/-- Convert a bijective continuous linear map `f : E →L[𝕜] F` from a Banach space to a normed space
to a continuous linear equivalence. -/
noncomputable def of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  E ≃L[𝕜] F :=
(linear_equiv.of_bijective ↑f (linear_map.ker_eq_bot.mp hinj) (linear_map.range_eq_top.mp hsurj))
.to_continuous_linear_equiv_of_continuous f.continuous

@[simp] lemma coe_fn_of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  ⇑(of_bijective f hinj hsurj) = f := rfl

lemma coe_of_bijective (f : E →L[𝕜] F) (hinj : f.ker = ⊥) (hsurj : f.range = ⊤) :
  ↑(of_bijective f hinj hsurj) = f := by { ext, refl }

@[simp] lemma of_bijective_symm_apply_apply (f : E →L[𝕜] F) (hinj : f.ker = ⊥)
  (hsurj : f.range = ⊤) (x : E) :
  (of_bijective f hinj hsurj).symm (f x) = x :=
(of_bijective f hinj hsurj).symm_apply_apply x

@[simp] lemma of_bijective_apply_symm_apply (f : E →L[𝕜] F) (hinj : f.ker = ⊥)
  (hsurj : f.range = ⊤) (y : F) :
  f ((of_bijective f hinj hsurj).symm y) = y :=
(of_bijective f hinj hsurj).apply_symm_apply y

end continuous_linear_equiv

namespace continuous_linear_map

variables [complete_space E]

/-- Intermediate definition used to show
`continuous_linear_map.closed_complemented_range_of_is_compl_of_ker_eq_bot`.

This is `f.coprod G.subtypeL` as an `continuous_linear_equiv`. -/
noncomputable def coprod_subtypeL_equiv_of_is_compl
  (f : E →L[𝕜] F) {G : submodule 𝕜 F}
  (h : is_compl f.range G) [complete_space G] (hker : f.ker = ⊥) : (E × G) ≃L[𝕜] F :=
continuous_linear_equiv.of_bijective (f.coprod G.subtypeL)
  (begin
    rw ker_coprod_of_disjoint_range,
    { rw [hker, submodule.ker_subtypeL, submodule.prod_bot] },
    { rw submodule.range_subtypeL,
      exact h.disjoint }
  end)
  (by simp only [range_coprod, h.sup_eq_top, submodule.range_subtypeL])

lemma range_eq_map_coprod_subtypeL_equiv_of_is_compl
  (f : E →L[𝕜] F) {G : submodule 𝕜 F}
  (h : is_compl f.range G) [complete_space G] (hker : f.ker = ⊥) :
    f.range = ((⊤ : submodule 𝕜 E).prod (⊥ : submodule 𝕜 G)).map
      (f.coprod_subtypeL_equiv_of_is_compl h hker : E × G →ₗ[𝕜] F) :=
by rw [coprod_subtypeL_equiv_of_is_compl, _root_.coe_coe, continuous_linear_equiv.coe_of_bijective,
    coe_coprod, linear_map.coprod_map_prod, submodule.map_bot, sup_bot_eq, submodule.map_top,
    range]

/- TODO: remove the assumption `f.ker = ⊥` in the next lemma, by using the map induced by `f` on
`E / f.ker`, once we have quotient normed spaces. -/
lemma closed_complemented_range_of_is_compl_of_ker_eq_bot (f : E →L[𝕜] F) (G : submodule 𝕜 F)
  (h : is_compl f.range G) (hG : is_closed (G : set F)) (hker : f.ker = ⊥) :
  is_closed (f.range : set F) :=
begin
  haveI : complete_space G := hG.complete_space_coe,
  let g := coprod_subtypeL_equiv_of_is_compl f h hker,
  rw congr_arg coe (range_eq_map_coprod_subtypeL_equiv_of_is_compl f h hker ),
  apply g.to_homeomorph.is_closed_image.2,
  exact is_closed_univ.prod is_closed_singleton,
end

end continuous_linear_map

section closed_graph_thm

variables [complete_space E] (g : E →ₗ[𝕜] F)

/-- The **closed graph theorem** : a linear map between two Banach spaces whose graph is closed
is continuous. -/
theorem linear_map.continuous_of_is_closed_graph (hg : is_closed (g.graph : set $ E × F)) :
  continuous g :=
begin
  letI : complete_space g.graph := complete_space_coe_iff_is_complete.mpr hg.is_complete,
  let φ₀ : E →ₗ[𝕜] E × F := linear_map.id.prod g,
  have : function.left_inverse prod.fst φ₀ := λ x, rfl,
  let φ : E ≃ₗ[𝕜] g.graph :=
    (linear_equiv.of_left_inverse this).trans
    (linear_equiv.of_eq _ _ g.graph_eq_range_prod.symm),
  let ψ : g.graph ≃L[𝕜] E := φ.symm.to_continuous_linear_equiv_of_continuous
    continuous_subtype_coe.fst,
  exact (continuous_subtype_coe.comp ψ.symm.continuous).snd
end

/-- A useful form of the **closed graph theorem** : let `f` be a linear map between two Banach
spaces. To show that `f` is continuous, it suffices to show that for any convergent sequence
`uₙ ⟶ x`, if `f(uₙ) ⟶ y` then `y = f(x)`. -/
theorem linear_map.continuous_of_seq_closed_graph
  (hg : ∀ (u : ℕ → E) x y, tendsto u at_top (𝓝 x) → tendsto (g ∘ u) at_top (𝓝 y) → y = g x) :
  continuous g :=
begin
  refine g.continuous_of_is_closed_graph (is_seq_closed_iff_is_closed.mp $ is_seq_closed_of_def _),
  rintros φ ⟨x, y⟩ hφg hφ,
  refine hg (prod.fst ∘ φ) x y ((continuous_fst.tendsto _).comp hφ) _,
  have : g ∘ prod.fst ∘ φ = prod.snd ∘ φ,
  { ext n,
    exact (hφg n).symm },
  rw this,
  exact (continuous_snd.tendsto _).comp hφ
end

variable {g}

namespace continuous_linear_map

/-- Upgrade a `linear_map` to a `continuous_linear_map` using the **closed graph theorem**. -/
def of_is_closed_graph (hg : is_closed (g.graph : set $ E × F)) :
  E →L[𝕜] F :=
{ to_linear_map := g,
  cont := g.continuous_of_is_closed_graph hg }

@[simp] lemma coe_fn_of_is_closed_graph (hg : is_closed (g.graph : set $ E × F)) :
  ⇑(continuous_linear_map.of_is_closed_graph hg) = g := rfl

lemma coe_of_is_closed_graph (hg : is_closed (g.graph : set $ E × F)) :
  ↑(continuous_linear_map.of_is_closed_graph hg) = g := by { ext, refl }

/-- Upgrade a `linear_map` to a `continuous_linear_map` using a variation on the
**closed graph theorem**. -/
def of_seq_closed_graph
  (hg : ∀ (u : ℕ → E) x y, tendsto u at_top (𝓝 x) → tendsto (g ∘ u) at_top (𝓝 y) → y = g x) :
  E →L[𝕜] F :=
{ to_linear_map := g,
  cont := g.continuous_of_seq_closed_graph hg }

@[simp] lemma coe_fn_of_seq_closed_graph
  (hg : ∀ (u : ℕ → E) x y, tendsto u at_top (𝓝 x) → tendsto (g ∘ u) at_top (𝓝 y) → y = g x) :
  ⇑(continuous_linear_map.of_seq_closed_graph hg) = g := rfl

lemma coe_of_seq_closed_graph
  (hg : ∀ (u : ℕ → E) x y, tendsto u at_top (𝓝 x) → tendsto (g ∘ u) at_top (𝓝 y) → y = g x) :
  ↑(continuous_linear_map.of_seq_closed_graph hg) = g := by { ext, refl }

end continuous_linear_map

end closed_graph_thm


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import data.list.sigma

/-!
# Association Lists

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

This file defines association lists. An association list is a list where every element consists of
a key and a value, and no two entries have the same key. The type of the value is allowed to be
dependent on the type of the key.

This type dependence is implemented using `sigma`: The elements of the list are of type `sigma β`,
for some type index `β`.

## Main definitions

Association lists are represented by the `alist` structure. This file defines this structure and
provides ways to access, modify, and combine `alist`s.

* `alist.keys` returns a list of keys of the alist.
* `alist.has_mem` returns membership in the set of keys.
* `alist.erase` removes a certain key.
* `alist.insert` adds a key-value mapping to the list.
* `alist.union` combines two association lists.

## References

* <https://en.wikipedia.org/wiki/Association_list>

-/

universes u v w
open list
variables {α : Type u} {β : α → Type v}

/-- `alist β` is a key-value map stored as a `list` (i.e. a linked list).
  It is a wrapper around certain `list` functions with the added constraint
  that the list have unique keys. -/
structure alist (β : α → Type v) : Type (max u v) :=
(entries : list (sigma β))
(nodupkeys : entries.nodupkeys)

/-- Given `l : list (sigma β)`, create a term of type `alist β` by removing
entries with duplicate keys. -/
def list.to_alist [decidable_eq α] {β : α → Type v} (l : list (sigma β)) : alist β :=
{ entries := _,
  nodupkeys := nodupkeys_dedupkeys l }

namespace alist

@[ext] theorem ext : ∀ {s t : alist β}, s.entries = t.entries → s = t
| ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ H := by congr'

lemma ext_iff {s t : alist β} : s = t ↔ s.entries = t.entries :=
⟨congr_arg _, ext⟩

instance [decidable_eq α] [∀ a, decidable_eq (β a)] : decidable_eq (alist β) :=
λ xs ys, by rw ext_iff; apply_instance

/-! ### keys -/

/-- The list of keys of an association list. -/
def keys (s : alist β) : list α := s.entries.keys

theorem keys_nodup (s : alist β) : s.keys.nodup := s.nodupkeys

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : has_mem α (alist β) := ⟨λ a s, a ∈ s.keys⟩

theorem mem_keys {a : α} {s : alist β} : a ∈ s ↔ a ∈ s.keys := iff.rfl

theorem mem_of_perm {a : α} {s₁ s₂ : alist β} (p : s₁.entries ~ s₂.entries) : a ∈ s₁ ↔ a ∈ s₂ :=
(p.map sigma.fst).mem_iff

/-! ### empty -/

/-- The empty association list. -/
instance : has_emptyc (alist β) := ⟨⟨[], nodupkeys_nil⟩⟩

instance : inhabited (alist β) := ⟨∅⟩

@[simp] theorem not_mem_empty (a : α) : a ∉ (∅ : alist β) :=
not_mem_nil a

@[simp] theorem empty_entries : (∅ : alist β).entries = [] := rfl

@[simp] theorem keys_empty : (∅ : alist β).keys = [] := rfl

/-! ### singleton -/

/-- The singleton association list. -/
def singleton (a : α) (b : β a) : alist β :=
⟨[⟨a, b⟩], nodupkeys_singleton _⟩

@[simp]

@[simp] theorem keys_singleton (a : α) (b : β a) : (singleton a b).keys = [a] := rfl

/-! ### lookup -/

section

variables [decidable_eq α]

/-- Look up the value associated to a key in an association list. -/
def lookup (a : α) (s : alist β) : option (β a) :=
s.entries.lookup a

@[simp] theorem lookup_empty (a) : lookup a (∅ : alist β) = none :=
rfl

theorem lookup_is_some {a : α} {s : alist β} :
  (s.lookup a).is_some ↔ a ∈ s := lookup_is_some

theorem lookup_eq_none {a : α} {s : alist β} :
  lookup a s = none ↔ a ∉ s :=
lookup_eq_none

theorem mem_lookup_iff {a : α} {b : β a} {s : alist β} :
  b ∈ lookup a s ↔ sigma.mk a b ∈ s.entries :=
mem_lookup_iff s.nodupkeys

theorem perm_lookup {a : α} {s₁ s₂ : alist β} (p : s₁.entries ~ s₂.entries) :
  s₁.lookup a = s₂.lookup a :=
perm_lookup _ s₁.nodupkeys s₂.nodupkeys p

instance (a : α) (s : alist β) : decidable (a ∈ s) :=
decidable_of_iff _ lookup_is_some

/-! ### replace -/

/-- Replace a key with a given value in an association list.
  If the key is not present it does nothing. -/
def replace (a : α) (b : β a) (s : alist β) : alist β :=
⟨kreplace a b s.entries, (kreplace_nodupkeys a b).2 s.nodupkeys⟩

@[simp] theorem keys_replace (a : α) (b : β a) (s : alist β) :
  (replace a b s).keys = s.keys :=
keys_kreplace _ _ _

@[simp] theorem mem_replace {a a' : α} {b : β a} {s : alist β} :
  a' ∈ replace a b s ↔ a' ∈ s :=
by rw [mem_keys, keys_replace, ←mem_keys]

theorem perm_replace {a : α} {b : β a} {s₁ s₂ : alist β} :
  s₁.entries ~ s₂.entries → (replace a b s₁).entries ~ (replace a b s₂).entries :=
perm.kreplace s₁.nodupkeys

end

/-- Fold a function over the key-value pairs in the map. -/
def foldl {δ : Type w} (f : δ → Π a, β a → δ) (d : δ) (m : alist β) : δ :=
m.entries.foldl (λ r a, f r a.1 a.2) d

/-! ### erase -/

section

variables [decidable_eq α]

/-- Erase a key from the map. If the key is not present, do nothing. -/
def erase (a : α) (s : alist β) : alist β := ⟨s.entries.kerase a, s.nodupkeys.kerase a⟩

@[simp] lemma keys_erase (a : α) (s : alist β) : (erase a s).keys = s.keys.erase a := keys_kerase

@[simp] theorem mem_erase {a a' : α} {s : alist β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
by rw [mem_keys, keys_erase, s.keys_nodup.mem_erase_iff, ←mem_keys]

theorem perm_erase {a : α} {s₁ s₂ : alist β} :
  s₁.entries ~ s₂.entries → (erase a s₁).entries ~ (erase a s₂).entries :=
perm.kerase s₁.nodupkeys

@[simp] theorem lookup_erase (a) (s : alist β) : lookup a (erase a s) = none :=
lookup_kerase a s.nodupkeys

@[simp] theorem lookup_erase_ne {a a'} {s : alist β} (h : a ≠ a') :
  lookup a (erase a' s) = lookup a s :=
lookup_kerase_ne h

theorem erase_erase (a a' : α) (s : alist β) :
  (s.erase a).erase a' = (s.erase a').erase a :=
ext $ kerase_kerase

/-! ### insert -/

/-- Insert a key-value pair into an association list and erase any existing pair
  with the same key. -/
def insert (a : α) (b : β a) (s : alist β) : alist β :=
⟨kinsert a b s.entries, kinsert_nodupkeys a b s.nodupkeys⟩

@[simp] theorem insert_entries {a} {b : β a} {s : alist β} :
  (insert a b s).entries = sigma.mk a b :: kerase a s.entries :=
rfl

theorem insert_entries_of_neg {a} {b : β a} {s : alist β} (h : a ∉ s) :
  (insert a b s).entries = ⟨a, b⟩ :: s.entries :=
by rw [insert_entries, kerase_of_not_mem_keys h]

-- Todo: rename to `insert_of_not_mem`.
theorem insert_of_neg {a} {b : β a} {s : alist β} (h : a ∉ s) :
  insert a b s = ⟨⟨a, b⟩ :: s.entries, nodupkeys_cons.2 ⟨h, s.2⟩⟩ :=
ext $ insert_entries_of_neg h

@[simp] theorem insert_empty (a) (b : β a) : insert a b ∅ = singleton a b := rfl

@[simp] theorem mem_insert {a a'} {b' : β a'} (s : alist β) :
  a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
mem_keys_kinsert

@[simp] theorem keys_insert {a} {b : β a} (s : alist β) :
  (insert a b s).keys = a :: s.keys.erase a :=
by simp [insert, keys, keys_kerase]

theorem perm_insert {a} {b : β a} {s₁ s₂ : alist β} (p : s₁.entries ~ s₂.entries) :
  (insert a b s₁).entries ~ (insert a b s₂).entries :=
by simp only [insert_entries]; exact p.kinsert s₁.nodupkeys

@[simp] theorem lookup_insert {a} {b : β a} (s : alist β) : lookup a (insert a b s) = some b :=
by simp only [lookup, insert, lookup_kinsert]

@[simp] theorem lookup_insert_ne {a a'} {b' : β a'} {s : alist β} (h : a ≠ a') :
  lookup a (insert a' b' s) = lookup a s :=
lookup_kinsert_ne h

@[simp] theorem lookup_to_alist {a} (s : list (sigma β)) : lookup a s.to_alist = s.lookup a :=
by rw [list.to_alist,lookup,lookup_dedupkeys]

@[simp] theorem insert_insert {a} {b b' : β a} (s : alist β) :
  (s.insert a b).insert a b' = s.insert a b' :=
by ext : 1; simp only [alist.insert_entries, list.kerase_cons_eq];
   constructor_matching* [_ ∧ _]; refl

theorem insert_insert_of_ne {a a'} {b : β a} {b' : β a'} (s : alist β) (h : a ≠ a') :
  ((s.insert a b).insert a' b').entries ~ ((s.insert a' b').insert a b).entries :=
by simp only [insert_entries]; rw [kerase_cons_ne,kerase_cons_ne,kerase_comm];
   [apply perm.swap, exact h, exact h.symm]

@[simp] lemma insert_singleton_eq {a : α} {b b' : β a} :
  insert a b (singleton a b') = singleton a b :=
ext $ by simp only [alist.insert_entries, list.kerase_cons_eq, and_self, alist.singleton_entries,
  heq_iff_eq, eq_self_iff_true]

@[simp] theorem entries_to_alist (xs : list (sigma β)) :
  (list.to_alist xs).entries = dedupkeys xs := rfl

theorem to_alist_cons (a : α) (b : β a) (xs : list (sigma β)) :
  list.to_alist (⟨a,b⟩ :: xs) = insert a b xs.to_alist := rfl

theorem mk_cons_eq_insert (c : sigma β) (l : list (sigma β)) (h : (c :: l).nodupkeys) :
  (⟨c :: l, h⟩ : alist β) = insert c.1 c.2 ⟨l, nodupkeys_of_nodupkeys_cons h⟩ :=
by simpa [insert] using (kerase_of_not_mem_keys $ not_mem_keys_of_nodupkeys_cons h).symm

/-- Recursion on an `alist`, using `insert`. Use as `induction l using alist.insert_rec`. -/
@[elab_as_eliminator] def insert_rec {C : alist β → Sort*} (H0 : C ∅)
  (IH : Π (a : α) (b : β a) (l : alist β) (h : a ∉ l), C l → C (l.insert a b)) : Π l : alist β, C l
| ⟨[], _⟩     := H0
| ⟨c :: l, h⟩ := begin
  rw mk_cons_eq_insert,
  refine IH _ _ _ _ (insert_rec _),
  exact not_mem_keys_of_nodupkeys_cons h
end

-- Test that the `induction` tactic works on `insert_rec`.
example (l : alist β) : true := by induction l using alist.insert_rec; trivial

@[simp] theorem insert_rec_empty {C : alist β → Sort*} (H0 : C ∅)
  (IH : Π (a : α) (b : β a) (l : alist β) (h : a ∉ l), C l → C (l.insert a b)) :
  @insert_rec α β _ C H0 IH ∅ = H0 :=
by { change @insert_rec α β _ C H0 IH ⟨[], _⟩ = H0, rw insert_rec }

theorem insert_rec_insert {C : alist β → Sort*} (H0 : C ∅)
  (IH : Π (a : α) (b : β a) (l : alist β) (h : a ∉ l), C l → C (l.insert a b))
  {c : sigma β} {l : alist β} (h : c.1 ∉ l) :
  @insert_rec α β _ C H0 IH (l.insert c.1 c.2) = IH c.1 c.2 l h (@insert_rec α β _ C H0 IH l) :=
begin
  cases l with l hl,
  suffices : @insert_rec α β _ C H0 IH ⟨c :: l, nodupkeys_cons.2 ⟨h, hl⟩⟩ ==
    IH c.1 c.2 ⟨l, hl⟩ h (@insert_rec α β _ C H0 IH ⟨l, hl⟩),
  { cases c,
    apply eq_of_heq,
    convert this;
      rw insert_of_neg h },
  rw insert_rec,
  apply cast_heq
end

theorem recursion_insert_mk {C : alist β → Sort*} (H0 : C ∅)
  (IH : Π (a : α) (b : β a) (l : alist β) (h : a ∉ l), C l → C (l.insert a b))
  {a : α} (b : β a) {l : alist β} (h : a ∉ l) :
  @insert_rec α β _ C H0 IH (l.insert a b) = IH a b l h (@insert_rec α β _ C H0 IH l) :=
@insert_rec_insert α β _ C H0 IH ⟨a, b⟩ l h

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract (a : α) (s : alist β) : option (β a) × alist β :=
have (kextract a s.entries).2.nodupkeys,
by rw [kextract_eq_lookup_kerase]; exact s.nodupkeys.kerase _,
match kextract a s.entries, this with
| (b, l), h := (b, ⟨l, h⟩)
end

@[simp] theorem extract_eq_lookup_erase (a : α) (s : alist β) :
  extract a s = (lookup a s, erase a s) :=
by simp [extract]; split; refl

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two association lists. It is
left-biased: if there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`.
-/
def union (s₁ s₂ : alist β) : alist β :=
⟨s₁.entries.kunion s₂.entries, s₁.nodupkeys.kunion s₂.nodupkeys⟩

instance : has_union (alist β) := ⟨union⟩

@[simp] theorem union_entries {s₁ s₂ : alist β} :
  (s₁ ∪ s₂).entries = kunion s₁.entries s₂.entries :=
rfl

@[simp] theorem empty_union {s : alist β} : (∅ : alist β) ∪ s = s :=
ext rfl

@[simp] theorem union_empty {s : alist β} : s ∪ (∅ : alist β) = s :=
ext $ by simp

@[simp] theorem mem_union {a} {s₁ s₂ : alist β} :
  a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
mem_keys_kunion

theorem perm_union {s₁ s₂ s₃ s₄ : alist β}
  (p₁₂ : s₁.entries ~ s₂.entries) (p₃₄ : s₃.entries ~ s₄.entries) :
  (s₁ ∪ s₃).entries ~ (s₂ ∪ s₄).entries :=
by simp [p₁₂.kunion s₃.nodupkeys p₃₄]

theorem union_erase (a : α) (s₁ s₂ : alist β) : erase a (s₁ ∪ s₂) = erase a s₁ ∪ erase a s₂ :=
ext kunion_kerase.symm

@[simp] theorem lookup_union_left {a} {s₁ s₂ : alist β} :
  a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
lookup_kunion_left

@[simp] theorem lookup_union_right {a} {s₁ s₂ : alist β} :
  a ∉ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
lookup_kunion_right

@[simp] theorem mem_lookup_union {a} {b : β a} {s₁ s₂ : alist β} :
  b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ a ∉ s₁ ∧ b ∈ lookup a s₂ :=
mem_lookup_kunion

theorem mem_lookup_union_middle {a} {b : β a} {s₁ s₂ s₃ : alist β} :
  b ∈ lookup a (s₁ ∪ s₃) → a ∉ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
mem_lookup_kunion_middle

theorem insert_union {a} {b : β a} {s₁ s₂ : alist β} :
  insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
by ext; simp

theorem union_assoc {s₁ s₂ s₃ : alist β} : ((s₁ ∪ s₂) ∪ s₃).entries ~ (s₁ ∪ (s₂ ∪ s₃)).entries :=
lookup_ext (alist.nodupkeys _) (alist.nodupkeys _)
(by simp [decidable.not_or_iff_and_not,or_assoc,and_or_distrib_left,and_assoc])

end

/-! ### disjoint -/

/-- Two associative lists are disjoint if they have no common keys. -/
def disjoint (s₁ s₂ : alist β) : Prop :=
∀ k ∈ s₁.keys, ¬ k ∈ s₂.keys

variables [decidable_eq α]

theorem union_comm_of_disjoint {s₁ s₂ : alist β} (h : disjoint s₁ s₂) :
  (s₁ ∪ s₂).entries ~ (s₂ ∪ s₁).entries :=
lookup_ext (alist.nodupkeys _) (alist.nodupkeys _)
(begin
   intros, simp,
   split; intro h',
   cases h',
   { right, refine ⟨_,h'⟩,
     apply h, rw [keys,← list.lookup_is_some,h'], exact rfl },
   { left, rw h'.2 },
   cases h',
   { right, refine ⟨_,h'⟩, intro h'',
     apply h _ h'', rw [keys,← list.lookup_is_some,h'], exact rfl },
   { left, rw h'.2 },
 end)

end alist


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

import algebraic_topology.dold_kan.faces
import category_theory.idempotents.basic

/-!

# Construction of projections for the Dold-Kan correspondence

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

In this file, we construct endomorphisms `P q : K[X] ⟶ K[X]` for all
`q : ℕ`. We study how they behave with respect to face maps with the lemmas
`higher_faces_vanish.of_P`, `higher_faces_vanish.comp_P_eq_self` and
`comp_P_eq_self_iff`.

Then, we show that they are projections (see `P_f_idem`
and `P_idem`). They are natural transformations (see `nat_trans_P`
and `P_f_naturality`) and are compatible with the application
of additive functors (see `map_P`).

By passing to the limit, these endomorphisms `P q` shall be used in `p_infty.lean`
in order to define `P_infty : K[X] ⟶ K[X]`, see `equivalence.lean` for the general
strategy of proof of the Dold-Kan equivalence.

-/

open category_theory category_theory.category category_theory.limits
  category_theory.preadditive category_theory.simplicial_object opposite
  category_theory.idempotents
open_locale simplicial dold_kan

noncomputable theory

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C] {X : simplicial_object C}

/-- This is the inductive definition of the projections `P q : K[X] ⟶ K[X]`,
with `P 0 := 𝟙 _` and `P (q+1) := P q ≫ (𝟙 _ + Hσ q)`. -/
noncomputable def P : ℕ → (K[X] ⟶ K[X])
| 0     := 𝟙 _
| (q+1) := P q ≫ (𝟙 _ + Hσ q)

/-- All the `P q` coincide with `𝟙 _` in degree 0. -/
@[simp]
lemma P_f_0_eq (q : ℕ) : ((P q).f 0 : X _[0] ⟶ X _[0]) = 𝟙 _ :=
begin
  induction q with q hq,
  { refl, },
  { unfold P,
    simp only [homological_complex.add_f_apply, homological_complex.comp_f,
      homological_complex.id_f, id_comp, hq, Hσ_eq_zero, add_zero], },
end

/-- `Q q` is the complement projection associated to `P q` -/
def Q (q : ℕ) : K[X] ⟶ K[X] := 𝟙 _ - P q

lemma P_add_Q (q : ℕ) : P q + Q q = 𝟙 K[X] := by { rw Q, abel, }

lemma P_add_Q_f (q n : ℕ) : (P q).f n + (Q q).f n = 𝟙 (X _[n]) :=
homological_complex.congr_hom (P_add_Q q) n

@[simp]
lemma Q_eq_zero : (Q 0 : K[X] ⟶ _) = 0 := sub_self _

lemma Q_eq (q : ℕ) : (Q (q+1) : K[X] ⟶ _) = Q q - P q ≫ Hσ q :=
by { unfold Q P, simp only [comp_add, comp_id], abel, }

/-- All the `Q q` coincide with `0` in degree 0. -/
@[simp]
lemma Q_f_0_eq (q : ℕ) : ((Q q).f 0 : X _[0] ⟶ X _[0]) = 0 :=
by simp only [homological_complex.sub_f_apply, homological_complex.id_f, Q, P_f_0_eq, sub_self]

namespace higher_faces_vanish

/-- This lemma expresses the vanishing of
`(P q).f (n+1) ≫ X.δ k : X _[n+1] ⟶ X _[n]` when `k≠0` and `k≥n-q+2` -/
lemma of_P : Π (q n : ℕ), higher_faces_vanish q (((P q).f (n+1) : X _[n+1] ⟶ X _[n+1]))
| 0     := λ n j hj₁, by { exfalso, have hj₂ := fin.is_lt j, linarith, }
| (q+1) := λ n, by { unfold P, exact (of_P q n).induction, }

@[reassoc]
lemma comp_P_eq_self {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) : φ ≫ (P q).f (n+1) = φ :=
begin
  induction q with q hq,
  { unfold P,
    apply comp_id, },
  { unfold P,
    simp only [comp_add, homological_complex.comp_f, homological_complex.add_f_apply,
      comp_id, ← assoc, hq v.of_succ, add_right_eq_self],
    by_cases hqn : n<q,
    { exact v.of_succ.comp_Hσ_eq_zero hqn, },
    { cases nat.le.dest (not_lt.mp hqn) with a ha,
      have hnaq : n=a+q := by linarith,
      simp only [v.of_succ.comp_Hσ_eq hnaq, neg_eq_zero, ← assoc],
      have eq := v ⟨a, by linarith⟩
        (by simp only [hnaq, fin.coe_mk, nat.succ_eq_add_one, add_assoc]),
      simp only [fin.succ_mk] at eq,
      simp only [eq, zero_comp], }, },
end

end higher_faces_vanish

lemma comp_P_eq_self_iff {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]} :
  φ ≫ (P q).f (n+1) = φ ↔ higher_faces_vanish q φ :=
begin
  split,
  { intro hφ,
    rw ← hφ,
    apply higher_faces_vanish.of_comp,
    apply higher_faces_vanish.of_P, },
  { exact higher_faces_vanish.comp_P_eq_self, },
end

@[simp, reassoc]
lemma P_f_idem (q n : ℕ) :
  ((P q).f n : X _[n] ⟶ _) ≫ ((P q).f n) = (P q).f n :=
begin
  cases n,
  { rw [P_f_0_eq q, comp_id], },
  { exact (higher_faces_vanish.of_P q n).comp_P_eq_self, }
end

@[simp, reassoc]
lemma Q_f_idem (q n : ℕ) :
  ((Q q).f n : X _[n] ⟶ _) ≫ ((Q q).f n) = (Q q).f n :=
idem_of_id_sub_idem _ (P_f_idem q n)

@[simp, reassoc]
lemma P_idem (q : ℕ) : (P q : K[X] ⟶ K[X]) ≫ P q = P q :=
by { ext n, exact P_f_idem q n, }

@[simp, reassoc]
lemma Q_idem (q : ℕ) : (Q q : K[X] ⟶ K[X]) ≫ Q q = Q q :=
by { ext n, exact Q_f_idem q n, }

/-- For each `q`, `P q` is a natural transformation. -/
@[simps]
def nat_trans_P (q : ℕ) :
  alternating_face_map_complex C ⟶ alternating_face_map_complex C :=
{ app := λ X, P q,
  naturality' := λ X Y f, begin
    induction q with q hq,
    { unfold P,
      dsimp only [alternating_face_map_complex],
      rw [id_comp, comp_id], },
    { unfold P,
      simp only [add_comp, comp_add, assoc, comp_id, hq],
      congr' 1,
      rw [← assoc, hq, assoc],
      congr' 1,
      exact (nat_trans_Hσ q).naturality' f, }
  end }

@[simp, reassoc]
lemma P_f_naturality (q n : ℕ) {X Y : simplicial_object C} (f : X ⟶ Y) :
  f.app (op [n]) ≫ (P q).f n = (P q).f n ≫ f.app (op [n]) :=
homological_complex.congr_hom ((nat_trans_P q).naturality f) n

@[simp, reassoc]
lemma Q_f_naturality (q n : ℕ) {X Y : simplicial_object C} (f : X ⟶ Y) :
  f.app (op [n]) ≫ (Q q).f n = (Q q).f n ≫ f.app (op [n]) :=
begin
  simp only [Q, homological_complex.sub_f_apply, homological_complex.id_f,
    comp_sub, P_f_naturality, sub_comp, sub_left_inj],
  dsimp,
  simp only [comp_id, id_comp],
end

/-- For each `q`, `Q q` is a natural transformation. -/
@[simps]
def nat_trans_Q (q : ℕ) :
  alternating_face_map_complex C ⟶ alternating_face_map_complex C :=
{ app := λ X, Q q, }

lemma map_P {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C) (q n : ℕ) :
  G.map ((P q : K[X] ⟶ _).f n) = (P q : K[((whiskering C D).obj G).obj X] ⟶ _).f n :=
begin
  induction q with q hq,
  { unfold P,
    apply G.map_id, },
  { unfold P,
    simp only [comp_add, homological_complex.comp_f, homological_complex.add_f_apply,
      comp_id, functor.map_add, functor.map_comp, hq, map_Hσ], }
end

lemma map_Q {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C) (q n : ℕ) :
  G.map ((Q q : K[X] ⟶ _).f n) = (Q q : K[((whiskering C D).obj G).obj X] ⟶ _).f n :=
begin
  rw [← add_right_inj (G.map ((P q : K[X] ⟶ _).f n)), ← G.map_add, map_P G X q n,
    P_add_Q_f, P_add_Q_f],
  apply G.map_id,
end

end dold_kan

end algebraic_topology


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

import algebra.group_power.identities
import data.zmod.basic
import field_theory.finite.basic
import data.int.parity
import data.fintype.card

/-!
# Lagrange's four square theorem

The main result in this file is `sum_four_squares`,
a proof that every natural number is the sum of four square numbers.

## Implementation Notes

The proof used is close to Lagrange's original proof.
-/

open finset polynomial finite_field equiv
open_locale big_operators

namespace int

lemma sq_add_sq_of_two_mul_sq_add_sq {m x y : ℤ} (h : 2 * m = x^2 + y^2) :
  m = ((x - y) / 2) ^ 2 + ((x + y) / 2) ^ 2 :=
have even (x^2 + y^2), by simp [h.symm, even_mul],
have hxaddy : even (x + y), by simpa [sq] with parity_simps,
have hxsuby : even (x - y), by simpa [sq] with parity_simps,
(mul_right_inj' (show (2*2 : ℤ) ≠ 0, from dec_trivial)).1 $
calc 2 * 2 * m = (x - y)^2 + (x + y)^2 : by rw [mul_assoc, h]; ring
... = (2 * ((x - y) / 2))^2 + (2 * ((x + y) / 2))^2 :
  by { rw even_iff_two_dvd at hxsuby hxaddy,
    rw [int.mul_div_cancel' hxsuby, int.mul_div_cancel' hxaddy] }
... = 2 * 2 * (((x - y) / 2) ^ 2 + ((x + y) / 2) ^ 2) :
  by simp [mul_add, pow_succ, mul_comm, mul_assoc, mul_left_comm]

lemma exists_sq_add_sq_add_one_eq_k (p : ℕ) [hp : fact p.prime] :
  ∃ (a b : ℤ) (k : ℕ), a^2 + b^2 + 1 = k * p ∧ k < p :=
hp.1.eq_two_or_odd.elim (λ hp2, hp2.symm ▸ ⟨1, 0, 1, rfl, dec_trivial⟩) $ λ hp1,
let ⟨a, b, hab⟩ := zmod.sq_add_sq p (-1) in
have hab' : (p : ℤ) ∣ a.val_min_abs ^ 2 + b.val_min_abs ^ 2 + 1,
  from (char_p.int_cast_eq_zero_iff (zmod p) p _).1 $ by simpa [eq_neg_iff_add_eq_zero] using hab,
let ⟨k, hk⟩ := hab' in
have hk0 : 0 ≤ k, from nonneg_of_mul_nonneg_left
  (by rw ← hk; exact (add_nonneg (add_nonneg (sq_nonneg _) (sq_nonneg _)) zero_le_one))
  (int.coe_nat_pos.2 hp.1.pos),
⟨a.val_min_abs, b.val_min_abs, k.nat_abs,
    by rw [hk, int.nat_abs_of_nonneg hk0, mul_comm],
  lt_of_mul_lt_mul_left
    (calc p * k.nat_abs = a.val_min_abs.nat_abs ^ 2 + b.val_min_abs.nat_abs ^ 2 + 1 :
        by rw [← int.coe_nat_inj', int.coe_nat_add, int.coe_nat_add, int.coe_nat_pow,
          int.coe_nat_pow, int.nat_abs_sq, int.nat_abs_sq,
          int.coe_nat_one, hk, int.coe_nat_mul, int.nat_abs_of_nonneg hk0]
      ... ≤ (p / 2) ^ 2 + (p / 2)^2 + 1 :
        add_le_add
          (add_le_add
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
          le_rfl
      ... < (p / 2) ^ 2 + (p / 2)^ 2 + (p % 2)^2 + ((2 * (p / 2)^2 + (4 * (p / 2) * (p % 2)))) :
        by rw [hp1, one_pow, mul_one];
          exact (lt_add_iff_pos_right _).2
            (add_pos_of_nonneg_of_pos (nat.zero_le _) (mul_pos dec_trivial
              (nat.div_pos hp.1.two_le dec_trivial)))
      ... = p * p : by { conv_rhs { rw [← nat.mod_add_div p 2] }, ring })
    (show 0 ≤ p, from nat.zero_le _)⟩

end int

namespace nat

open int

open_locale classical

private lemma sum_four_squares_of_two_mul_sum_four_squares {m a b c d : ℤ}
  (h : a^2 + b^2 + c^2 + d^2 = 2 * m) : ∃ w x y z : ℤ, w^2 + x^2 + y^2 + z^2 = m :=
have ∀ f : fin 4 → zmod 2, (f 0)^2 + (f 1)^2 + (f 2)^2 + (f 3)^2 = 0 →
    ∃ i : (fin 4), (f i)^2 + f (swap i 0 1)^2 = 0 ∧ f (swap i 0 2)^2 + f (swap i 0 3)^2 = 0,
  from dec_trivial,
let f : fin 4 → ℤ :=
  vector.nth (a ::ᵥ b ::ᵥ c ::ᵥ d ::ᵥ vector.nil) in
let ⟨i, hσ⟩ := this (coe ∘ f) (by rw [← @zero_mul (zmod 2) _ m,
  ← show ((2 : ℤ) : zmod 2) = 0, from rfl,
  ← int.cast_mul, ← h]; simp only [int.cast_add, int.cast_pow]; refl) in
let σ := swap i 0 in
have h01 : 2 ∣ f (σ 0) ^ 2 + f (σ 1) ^ 2,
  from (char_p.int_cast_eq_zero_iff (zmod 2) 2 _).1 $ by simpa [σ] using hσ.1,
have h23 : 2 ∣ f (σ 2) ^ 2 + f (σ 3) ^ 2,
  from (char_p.int_cast_eq_zero_iff (zmod 2) 2 _).1 $ by simpa using hσ.2,
let ⟨x, hx⟩ := h01 in let ⟨y, hy⟩ := h23 in
⟨(f (σ 0) - f (σ 1)) / 2, (f (σ 0) + f (σ 1)) / 2, (f (σ 2) - f (σ 3)) / 2, (f (σ 2) + f (σ 3)) / 2,
  begin
    rw [← int.sq_add_sq_of_two_mul_sq_add_sq hx.symm, add_assoc,
      ← int.sq_add_sq_of_two_mul_sq_add_sq hy.symm,
      ← mul_right_inj' (show (2 : ℤ) ≠ 0, from dec_trivial), ← h, mul_add, ← hx, ← hy],
    have : ∑ x, f (σ x)^2 = ∑ x, f x^2,
    { conv_rhs { rw ←equiv.sum_comp σ } },
    have fin4univ : (univ : finset (fin 4)).1 = 0 ::ₘ 1 ::ₘ 2 ::ₘ 3 ::ₘ 0, from dec_trivial,
    simpa [finset.sum_eq_multiset_sum, fin4univ, multiset.sum_cons, f, add_assoc]
  end⟩

private lemma prime_sum_four_squares (p : ℕ) [hp : _root_.fact p.prime] :
  ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = p :=
have hm : ∃ m < p, 0 < m ∧ ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = m * p,
  from let ⟨a, b, k, hk⟩ := exists_sq_add_sq_add_one_eq_k p in
  ⟨k, hk.2, nat.pos_of_ne_zero $
    (λ hk0, by { rw [hk0, int.coe_nat_zero, zero_mul] at hk,
      exact ne_of_gt (show a^2 + b^2 + 1 > 0, from add_pos_of_nonneg_of_pos
        (add_nonneg (sq_nonneg _) (sq_nonneg _)) zero_lt_one) hk.1 }),
    a, b, 1, 0, by simpa [sq] using hk.1⟩,
let m := nat.find hm in
let ⟨a, b, c, d, (habcd : a^2 + b^2 + c^2 + d^2 = m * p)⟩ := (nat.find_spec hm).snd.2 in
by haveI hm0 : _root_.fact (0 < m) := ⟨(nat.find_spec hm).snd.1⟩; exact
have hmp : m < p, from (nat.find_spec hm).fst,
m.mod_two_eq_zero_or_one.elim
  (λ hm2 : m % 2 = 0,
    let ⟨k, hk⟩ := (nat.dvd_iff_mod_eq_zero _ _).2 hm2 in
    have hk0 : 0 < k, from nat.pos_of_ne_zero $ λ _, by { simp [*, lt_irrefl] at * },
    have hkm : k < m, { rw [hk, two_mul], exact (lt_add_iff_pos_left _).2 hk0 },
    false.elim $ nat.find_min hm hkm ⟨lt_trans hkm hmp, hk0,
      sum_four_squares_of_two_mul_sum_four_squares
        (show a^2 + b^2 + c^2 + d^2 = 2 * (k * p),
          by { rw [habcd, hk, int.coe_nat_mul, mul_assoc], simp })⟩)
  (λ hm2 : m % 2 = 1,
    if hm1 : m = 1 then ⟨a, b, c, d, by simp only [hm1, habcd, int.coe_nat_one, one_mul]⟩
    else
      let w := (a : zmod m).val_min_abs, x := (b : zmod m).val_min_abs,
          y := (c : zmod m).val_min_abs, z := (d : zmod m).val_min_abs in
      have hnat_abs : w^2 + x^2 + y^2 + z^2 =
          (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs ^2 + z.nat_abs ^ 2 : ℕ),
        by simp [sq],
      have hwxyzlt : w^2 + x^2 + y^2 + z^2 < m^2,
        from calc w^2 + x^2 + y^2 + z^2
            = (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs ^2 + z.nat_abs ^ 2 : ℕ) : hnat_abs
        ... ≤ ((m / 2) ^ 2 + (m / 2) ^ 2 + (m / 2) ^ 2 + (m / 2) ^ 2 : ℕ) :
          int.coe_nat_le.2 $ add_le_add (add_le_add (add_le_add
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _))
            (nat.pow_le_pow_of_le_left (zmod.nat_abs_val_min_abs_le _) _)
        ... = 4 * (m / 2 : ℕ) ^ 2 : by simp [sq, bit0, bit1, mul_add, add_mul, add_assoc]
        ... < 4 * (m / 2 : ℕ) ^ 2 + ((4 * (m / 2) : ℕ) * (m % 2 : ℕ) + (m % 2 : ℕ)^2) :
          (lt_add_iff_pos_right _).2 (by { rw [hm2, int.coe_nat_one, one_pow, mul_one],
            exact add_pos_of_nonneg_of_pos (int.coe_nat_nonneg _) zero_lt_one })
        ... = m ^ 2 : by { conv_rhs {rw [← nat.mod_add_div m 2]},
          simp [-nat.mod_add_div, mul_add, add_mul, bit0, bit1, mul_comm, mul_assoc, mul_left_comm,
            pow_add, add_comm, add_left_comm] },
      have hwxyzabcd : ((w^2 + x^2 + y^2 + z^2 : ℤ) : zmod m) =
          ((a^2 + b^2 + c^2 + d^2 : ℤ) : zmod m),
        by simp [w, x, y, z, sq],
      have hwxyz0 : ((w^2 + x^2 + y^2 + z^2 : ℤ) : zmod m) = 0,
        by rw [hwxyzabcd, habcd, int.cast_mul, cast_coe_nat, zmod.nat_cast_self, zero_mul],
      let ⟨n, hn⟩ := ((char_p.int_cast_eq_zero_iff _ m _).1 hwxyz0) in
      have hn0 : 0 < n.nat_abs, from int.nat_abs_pos_of_ne_zero (λ hn0,
        have hwxyz0 : (w.nat_abs^2 + x.nat_abs^2 + y.nat_abs^2 + z.nat_abs^2 : ℕ) = 0,
          by { rw [← int.coe_nat_eq_zero, ← hnat_abs], rwa [hn0, mul_zero] at hn },
        have habcd0 : (m : ℤ) ∣ a ∧ (m : ℤ) ∣ b ∧ (m : ℤ) ∣ c ∧ (m : ℤ) ∣ d,
          by simpa [add_eq_zero_iff' (sq_nonneg (_ : ℤ)) (sq_nonneg _),
            pow_two, w, x, y, z, (char_p.int_cast_eq_zero_iff _ m _), and.assoc] using hwxyz0,
        let ⟨ma, hma⟩ := habcd0.1,     ⟨mb, hmb⟩ := habcd0.2.1,
            ⟨mc, hmc⟩ := habcd0.2.2.1, ⟨md, hmd⟩ := habcd0.2.2.2 in
        have hmdvdp : m ∣ p,
          from int.coe_nat_dvd.1 ⟨ma^2 + mb^2 + mc^2 + md^2,
            (mul_right_inj' (show (m : ℤ) ≠ 0, from int.coe_nat_ne_zero_iff_pos.2 hm0.1)).1 $
              by { rw [← habcd, hma, hmb, hmc, hmd], ring }⟩,
        (hp.1.eq_one_or_self_of_dvd _ hmdvdp).elim hm1
        (λ hmeqp, by simpa [lt_irrefl, hmeqp] using hmp)),
      have hawbxcydz : ((m : ℕ) : ℤ) ∣ a * w + b * x + c * y + d * z,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { rw [← hwxyz0], simp, ring },
      have haxbwczdy : ((m : ℕ) : ℤ) ∣ a * x - b * w - c * z + d * y,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { simp [sub_eq_add_neg], ring },
      have haybzcwdx : ((m : ℕ) : ℤ) ∣ a * y + b * z - c * w - d * x,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { simp [sub_eq_add_neg], ring },
      have hazbycxdw : ((m : ℕ) : ℤ) ∣ a * z - b * y + c * x - d * w,
        from (char_p.int_cast_eq_zero_iff (zmod m) m _).1 $ by { simp [sub_eq_add_neg], ring },
      let ⟨s, hs⟩ := hawbxcydz, ⟨t, ht⟩ := haxbwczdy, ⟨u, hu⟩ := haybzcwdx, ⟨v, hv⟩ := hazbycxdw in
      have hn_nonneg : 0 ≤ n,
        from nonneg_of_mul_nonneg_left
          (by { erw [← hn], repeat {try {refine add_nonneg _ _}, try {exact sq_nonneg _}} })
          (int.coe_nat_pos.2 hm0.1),
      have hnm : n.nat_abs < m,
        from int.coe_nat_lt.1 (lt_of_mul_lt_mul_left
          (by { rw [int.nat_abs_of_nonneg hn_nonneg, ← hn, ← sq], exact hwxyzlt })
          (int.coe_nat_nonneg m)),
      have hstuv : s^2 + t^2 + u^2 + v^2 = n.nat_abs * p,
        from (mul_right_inj' (show (m^2 : ℤ) ≠ 0, from pow_ne_zero 2
            (int.coe_nat_ne_zero_iff_pos.2 hm0.1))).1 $
          calc (m : ℤ)^2 * (s^2 + t^2 + u^2 + v^2) = ((m : ℕ) * s)^2 + ((m : ℕ) * t)^2 +
              ((m : ℕ) * u)^2 + ((m : ℕ) * v)^2 :
            by { simp [mul_pow], ring }
          ... = (w^2 + x^2 + y^2 + z^2) * (a^2 + b^2 + c^2 + d^2) :
            by { simp only [hs.symm, ht.symm, hu.symm, hv.symm], ring }
          ... = _ : by { rw [hn, habcd, int.nat_abs_of_nonneg hn_nonneg], dsimp [m], ring },
      false.elim $ nat.find_min hm hnm ⟨lt_trans hnm hmp, hn0, s, t, u, v, hstuv⟩)

/-- **Four squares theorem** -/
lemma sum_four_squares : ∀ n : ℕ, ∃ a b c d : ℕ, a^2 + b^2 + c^2 + d^2 = n
| 0 := ⟨0, 0, 0, 0, rfl⟩
| 1 := ⟨1, 0, 0, 0, rfl⟩
| n@(k+2) :=
have hm : _root_.fact (min_fac (k+2)).prime := ⟨min_fac_prime dec_trivial⟩,
have n / min_fac n < n := factors_lemma,
let ⟨a, b, c, d, h₁⟩ := show ∃ a b c d : ℤ, a^2 + b^2 + c^2 + d^2 = min_fac n,
  by exactI prime_sum_four_squares (min_fac (k+2)) in
let ⟨w, x, y, z, h₂⟩ := sum_four_squares (n / min_fac n) in
⟨(a * w - b * x - c * y - d * z).nat_abs,
 (a * x + b * w + c * z - d * y).nat_abs,
 (a * y - b * z + c * w + d * x).nat_abs,
 (a * z + b * y - c * x + d * w).nat_abs,
  begin
    rw [← int.coe_nat_inj', ← nat.mul_div_cancel' (min_fac_dvd (k+2)), int.coe_nat_mul, ← h₁, ← h₂],
    simp [sum_four_sq_mul_sum_four_sq],
  end⟩

end nat


theorem mul_left_cancel (a b c : ℕ) (ha : a ≠ 0) : a * b = a * c → b = c :=
begin
    intro h,
    induction c with d hd,
    rw nat.mul_zero at h,

end


import Lean.Meta
import Lean.Elab
import Mathlib.Algebra.Group.Defs
import UnitConjecture.Tactics.ReduceGoal
import Std
import Lean
import Experiments.ProdSeq
open Lean Meta Elab Nat Term Std ProdSeq

def Lean.Expr.simplify(e: Expr) : MetaM Expr := do
    let r ← simp e (← Simp.Context.mkDefault)
    return r.1.expr

def hOp? (fname: Name)(e : Expr)  : MetaM (Option (Expr × Expr)) := do
  let type ← inferType e
  if e.isAppOfArity fname 6 then
    let x := e.appFn!.appArg!
    let y := e.appArg!
    if (← isDefEq (← inferType x) type) &&
       (← isDefEq (← inferType y) type) then
      return some (x, y)
    else
      return none
  else
    return none

def invOp? (fname: Name)(e : Expr)  : MetaM (Option (Expr)) := do
  let type ← inferType e
  if e.isAppOfArity fname 4 then
    let y := e.appArg!
    if  (← isDefEq (← inferType y) type) then
      return some y
    else
      return none
  else
    return none

inductive AddTree (α : Type _)[Repr α] where
  | leaf : α → AddTree α
  | negLeaf : α → AddTree α
  | node : AddTree α  → AddTree α  → AddTree α
  | subNode: AddTree α  → AddTree α  → AddTree α

def AddTree.fold {α : Type _}[AddCommGroup α][Repr α]  (t : AddTree α ) : α :=
  match t with
  | AddTree.leaf a => a
  | AddTree.node l r =>  (fold l) + (fold r)
  | AddTree.negLeaf a => -a
  | AddTree.subNode l r => (fold l) - (fold r)

def AddTree.foldMul {α : Type _}[CommGroup α][Repr α]  (t : AddTree α ) : α :=
  match t with
  | AddTree.leaf a => a
  | AddTree.node l r =>  (foldMul l) * (foldMul r)
  | AddTree.negLeaf a => a⁻¹
  | AddTree.subNode l r => (foldMul l) / (foldMul r)

abbrev IndexAddTree := AddTree Nat

@[inline] def AddTree.indexTree {α : Type _}[Repr α][DecidableEq α](t: AddTree α)
  (accum : Array α := #[]) :
      IndexAddTree × (Array α) :=
  match t with
  | AddTree.leaf a =>
    match accum.getIdx? a with
    | some i => (AddTree.leaf i, accum)
    | none => (AddTree.leaf (accum.size), accum.push a)
  | AddTree.node l r =>
    let (lIdx, lAccum) := indexTree l accum
    let (rIdx, rAccum) := indexTree r lAccum
    (AddTree.node lIdx rIdx, rAccum)
  | AddTree.negLeaf a =>
    match accum.getIdx? a with
    | some i => (AddTree.negLeaf i, accum)
    | none => (AddTree.negLeaf (accum.size), accum.push a)
  | AddTree.subNode l r =>
    let (lIdx, lAccum) := indexTree l accum
    let (rIdx, rAccum) := indexTree r lAccum
    (AddTree.subNode lIdx rIdx, rAccum)

def AddTree.indexTreeM (t: AddTree Expr)(accumExpr : Expr) :
      TermElabM Expr := do
  let accumL ← unpack accumExpr
  let accum := accumL.toArray
  match t with
  | AddTree.leaf a =>
    match ← accum.findIdxM? fun e => isDefEq e a with
    | some i =>
      mkPair (← mkAppM ``AddTree.leaf #[ToExpr.toExpr i]) accumExpr
    | none =>
      let newAccum ← pack (accum.push a).toList
      mkPair (← mkAppM ``AddTree.leaf #[ToExpr.toExpr accum.size]) newAccum
  | AddTree.node l r =>
    let lexpr ← indexTreeM l accumExpr
    let (lIdx, lAccum) := (← split? lexpr).get!
    let rexpr ← indexTreeM r lAccum
    let (rIdx, rAccum) := (← split? rexpr).get!
    mkPair (← mkAppM ``AddTree.node #[lIdx, rIdx]) (rAccum)
  | AddTree.negLeaf a =>
    match ← accum.findIdxM? fun e => isDefEq e a with
    | some i =>
        mkPair (← mkAppM ``AddTree.negLeaf #[ToExpr.toExpr i]) accumExpr
    | none =>
      let newAccum ← pack (accum.push a).toList
      mkPair (← mkAppM ``AddTree.leaf #[ToExpr.toExpr accum.size]) newAccum
  | AddTree.subNode l r =>
    let lexpr ← indexTreeM l accumExpr
    let (lIdx, lAccum) := (← split? lexpr).get!
    let rexpr ← indexTreeM r lAccum
    let (rIdx, rAccum) := (← split? rexpr).get!
    mkPair (← mkAppM ``AddTree.subNode #[lIdx, rIdx]) (rAccum)

lemma Array.size_pos_if_index {α : Type _} [DecidableEq α] {arr : Array α} {a : α} {i : ℕ} : arr.getIdx? a = some i → arr.size > 0 := by
  rw [getIdx?, findIdx?, findIdx?.loop]
  exact if h:0 < arr.size then
    λ _ => h
  else by simp [h]

lemma Array.push_size_pos {α : Type _} (arr : Array α) (a : α) : (arr.push a).size > 0 := by
  match arr with
    | ⟨l⟩ =>
      simp only [push, size]
      induction l with
        | nil => simp only [List.concat, List.length]
        | cons _ _ _ => simp only [List.concat, List.length, Nat.add_one]; apply Nat.succ_pos

@[irreducible] theorem pos_size {α : Type _}[Repr α][DecidableEq α] (t: AddTree α) : (arr : Array α) → (t.indexTree arr).2.size > 0 := by
  induction t with
    | leaf a =>
      simp only [AddTree.indexTree]
      intro arr
      match h:arr.getIdx? a with
        | some i => simp only [h]; exact Array.size_pos_if_index h
        | none => simp only [h]; apply Array.push_size_pos
    | negLeaf a =>
      simp only [AddTree.indexTree]
      intro arr
      match h:arr.getIdx? a with
        | some i => simp only [h]; exact Array.size_pos_if_index h
        | none => simp only [h]; apply Array.push_size_pos
    | node _ _ _ ihr => simp only [AddTree.indexTree]; intro arr; apply ihr
    | subNode _ _ _ ihr => simp only [AddTree.indexTree]; intro arr; apply ihr

partial def treeM (e : Expr) : MetaM Expr := do
  match ← hOp? ``HAdd.hAdd e with
  | some (a, b) => do
    let l ← treeM a
    let r ← treeM b
    mkAppM ``AddTree.node #[l, r]
  | none  =>
  match ← hOp? ``HMul.hMul e with
  | some (a, b) => do
    let l ← treeM a
    let r ← treeM b
    mkAppM ``AddTree.node #[l, r]
  | none  =>
    match ← hOp? ``HSub.hSub e with
  | some (a, b) => do
    let l ← treeM a
    let r ← treeM b
    mkAppM ``AddTree.subNode #[l, r]
  | none  =>
  match ← hOp? ``HDiv.hDiv e with
  | some (a, b) => do
    let l ← treeM a
    let r ← treeM b
    mkAppM ``AddTree.subNode #[l, r]
  | none  =>
  match ← invOp? ``Neg.neg e with
  | some a => mkAppM ``AddTree.negLeaf #[a]
  | none  =>
  match ← invOp? ``Inv.inv e with
  | some a => mkAppM ``AddTree.negLeaf #[a]
  | none  =>
      mkAppM ``AddTree.leaf #[e]

partial def addTreeM (e : Expr) : MetaM <| AddTree Expr := do
  match ← hOp? ``HAdd.hAdd e with
  | some (a, b) => do
    let l ← addTreeM a
    let r ← addTreeM b
    return AddTree.node l r
  | none  =>
  match ← hOp? ``HMul.hMul e with
  | some (a, b) => do
    let l ← addTreeM a
    let r ← addTreeM b
    return AddTree.node l r
  | none  =>
    match ← hOp? ``HSub.hSub e with
  | some (a, b) => do
    let l ← addTreeM a
    let r ← addTreeM b
    return AddTree.subNode l r
  | none  =>
  match ← hOp? ``HDiv.hDiv e with
  | some (a, b) => do
    let l ← addTreeM a
    let r ← addTreeM b
    return AddTree.subNode l r
  | none  =>
  match ← invOp? ``Neg.neg e with
  | some a => return AddTree.negLeaf a
  | none  =>
  match ← invOp? ``Inv.inv e with
  | some a => return AddTree.negLeaf a
  | none  =>
      return AddTree.leaf e

@[simp] def IndexAddTree.foldMap {α : Type _}[AddCommGroup α][Repr α]
  (t : IndexAddTree)(basisImages: Array α)(h: basisImages.size > 0) : α :=
  match t with
  | AddTree.leaf i => basisImages.get (Fin.ofNat' i h)
  | AddTree.node l r =>
      let lImage := foldMap l basisImages h
      let rImage := foldMap r basisImages h
      lImage + rImage
  | AddTree.negLeaf i => -basisImages.get (Fin.ofNat' i h)
  | AddTree.subNode l r =>
      let lImage := foldMap l basisImages h
      let rImage := foldMap r basisImages h
      lImage - rImage

@[simp] def IndexAddTree.foldMap! {α : Type _}[AddCommGroup α][Repr α][Inhabited α]
  (t : IndexAddTree)(basisImages: Array α) : α :=
  match t with
  | AddTree.leaf i => basisImages.get! i
  | AddTree.node l r =>
      let lImage := foldMap! l basisImages
      let rImage := foldMap! r basisImages
      lImage + rImage
  | AddTree.negLeaf i => -basisImages.get! i
  | AddTree.subNode l r =>
      let lImage := foldMap! l basisImages
      let rImage := foldMap! r basisImages
      lImage - rImage

def IndexAddTree.foldMapMAux
  (t : IndexAddTree)(basisImages: Array Expr) : TermElabM Expr := do
  match t with
  | AddTree.leaf i => return basisImages.get! i
  | AddTree.node l r =>
      let lImage ←  foldMapMAux l basisImages
      let rImage ←  foldMapMAux r basisImages
      mkAppM ``HAdd.hAdd #[lImage, rImage]
  | AddTree.negLeaf i => mkAppM ``Neg.neg #[basisImages.get! i]
  | AddTree.subNode l r =>
      let lImage ←  foldMapMAux l basisImages
      let rImage ←  foldMapMAux r basisImages
      mkAppM ``HSub.hSub #[lImage, rImage]

partial def exprNatLeaf : Expr → TermElabM (Option Nat) := fun expr =>
  do
    let mvar ←  mkFreshExprMVar (some (mkConst ``Nat))
    let sExp' ← mkAppM ``AddTree.leaf #[mvar]
    let expr ← reduce expr
    Term.synthesizeSyntheticMVarsNoPostponing
    if ← isDefEq sExp' expr then
      Term.synthesizeSyntheticMVarsNoPostponing
      let index ← exprNat (← whnf mvar)
      return some index
    else
      return none

partial def exprNatNegLeaf : Expr → TermElabM (Option Nat) := fun expr =>
  do
    let mvar ←  mkFreshExprMVar (some (mkConst ``Nat))
    let sExp' ← mkAppM ``AddTree.negLeaf #[mvar]
    let expr ← reduce expr
    Term.synthesizeSyntheticMVarsNoPostponing
    if ← isDefEq sExp' expr then
      Term.synthesizeSyntheticMVarsNoPostponing
      let index ← exprNat (← whnf mvar)
      return some index
    else
      return none

elab "leafIndex!" t: term : term => do
  let e ← elabTerm t none
  let e ← reduce e
  let n? ← exprNatLeaf e
  return (ToExpr.toExpr <| n?.get!)

#eval leafIndex! (AddTree.leaf 7)

partial def exprNode : Expr → TermElabM (Option (Expr × Expr)) := fun expr =>
  do
    let mvar ←  mkFreshExprMVar (some (mkConst ``IndexAddTree))
    let mvar' ←  mkFreshExprMVar (some (mkConst ``IndexAddTree))
    let sExp' ← mkAppM ``AddTree.node #[mvar, mvar']
    let expr ← reduce expr
    Term.synthesizeSyntheticMVarsNoPostponing
    if ← isDefEq sExp' expr then
      Term.synthesizeSyntheticMVarsNoPostponing
      return some (mvar, mvar')
    else
      return none

partial def exprSubNode : Expr → TermElabM (Option (Expr × Expr)) := fun expr =>
  do
    let mvar ←  mkFreshExprMVar (some (mkConst ``IndexAddTree))
    let mvar' ←  mkFreshExprMVar (some (mkConst ``IndexAddTree))
    let sExp' ← mkAppM ``AddTree.subNode #[mvar, mvar']
    let expr ← reduce expr
    Term.synthesizeSyntheticMVarsNoPostponing
    if ← isDefEq sExp' expr then
      Term.synthesizeSyntheticMVarsNoPostponing
      return some (mvar, mvar')
    else
      return none

partial def exprIndexTree : Expr → TermElabM IndexAddTree := fun expr =>
  do
    match ← exprNode expr with
    | some (l, r) => do
      let l ← exprIndexTree l
      let r ← exprIndexTree r
      return AddTree.node l r
    | none  =>
      match ← exprSubNode expr with
    | some (l, r) => do
      let l ← exprIndexTree l
      let r ← exprIndexTree r
      return AddTree.subNode l r
    | none =>
      match ← exprNatLeaf expr with
      | some i => return AddTree.leaf i
      | none =>
        match ← exprNatNegLeaf expr with
      | some i => return AddTree.negLeaf i
      | none =>
        throwError s!"expression {expr} is not a leaf or node"

def IndexAddTree.toString (t: IndexAddTree) : String :=
  match t with
  | AddTree.leaf i => s!"leaf {i}"
  | AddTree.node l r =>
    "node (" ++ toString l ++ ") (" ++ toString r ++ ")"
  | AddTree.negLeaf i => s!"negLeaf {i}"
  | AddTree.subNode l r =>
    "subNode (" ++ toString l ++ ") (" ++ toString r ++")"

instance : ToString IndexAddTree := ⟨IndexAddTree.toString⟩

elab "checktree" t:term : term => do
    let e ← elabTerm t none
    let e ← reduce e
    let tree ← exprIndexTree e
    logInfo s!"got tree {tree}"
    return e

#eval checktree (AddTree.node (AddTree.leaf 7) (AddTree.leaf 8))

def IndexAddTree.foldMapM
  (tExp: Expr)(basisImages: Array Expr) : TermElabM Expr := do
  let t ← exprIndexTree tExp
  foldMapMAux t basisImages

def IndexAddTree.foldMapAux {α : Type _}[AddCommGroup α][Repr α]
  (t : IndexAddTree)(basisImages: Array α)(h: basisImages.size > 0) : α :=
  match t with
  | AddTree.leaf i => basisImages.get (Fin.ofNat' i h)
  | AddTree.node l r =>
      let lImage := foldMap l basisImages h
      let rImage := foldMap r basisImages h
      lImage + rImage
  | AddTree.negLeaf i => -basisImages.get (Fin.ofNat' i h)
  | AddTree.subNode l r =>
      let lImage := foldMap l basisImages h
      let rImage := foldMap r basisImages h
      lImage - rImage

@[simp] def foldPair{α : Type _}[AddCommGroup α][Repr α]
  (tb : IndexAddTree × Array α)(h: tb.snd.size > 0) : α  :=
  let (t, basisImages) := tb
  t.foldMap basisImages h

@[simp] def IndexAddTree.foldMapMul {α : Type _}[CommGroup α][Repr α]
  (t : IndexAddTree)(basisImages: Array α)(h: basisImages.size > 0) : α :=
  match t with
  | AddTree.leaf i => basisImages.get (Fin.ofNat' i h)
  | AddTree.node l r =>
      let lImage := foldMapMul l basisImages h
      let rImage := foldMapMul r basisImages h
      lImage * rImage
  | AddTree.negLeaf i => (basisImages.get (Fin.ofNat' i h))⁻¹
  | AddTree.subNode l r =>
      let lImage := foldMapMul l basisImages h
      let rImage := foldMapMul r basisImages h
      lImage / rImage

@[simp, reducible] def AddTree.indexTree₀  {α : Type _}[Repr α][DecidableEq α](t: AddTree α) :
    IndexAddTree × {a : Array α // a.size > 0} :=
    let indT := (t.indexTree #[]).fst
    let arr := (t.indexTree #[]).snd
    let p : arr.size > 0 := by apply pos_size
    (indT, ⟨arr, p⟩)

elab "indexTree#" t:term : term => do
  let e ← elabTerm t none
  let t ← treeM e
  let res ← mkAppM ``AddTree.indexTree₀ #[t]
  reduce res

def listToExpr (lst: List Expr) : MetaM (Expr × Expr) := do
    let α ← inferType lst.head!
    let nilList ←  mkAppOptM ``List.nil #[some α]
    return (← lst.foldrM (fun l i => do
      mkAppOptM  ``List.cons #[some α, some l, some i]) nilList,
      α)

def AddTree.indexTreeM' (t : AddTree Expr) : TermElabM Expr :=
  do
    let res ← AddTree.indexTreeM t (mkConst ``Unit.unit)
    let res ← reduce res
    let (tree, lstIn) := (← split? res).get!
    let lst ← unpack lstIn
    let lstExprPair ←  listToExpr lst
    let (lstExpr, _) := lstExprPair
    mkAppM ``Prod.mk #[tree, lstExpr]

def AddTree.indexTreeM'' (t : AddTree Expr) :
  TermElabM <| Expr × (List Expr) :=
  do
    let res ← AddTree.indexTreeM t (mkConst ``Unit.unit)
    let res ← reduce res
    let (tree, lstIn) := (← split? res).get!
    let lst ← unpack lstIn
    return (tree, lst)

elab "roundtrip#" t:term : term => do
  let e ← elabTerm t none
  let t ← addTreeM e
  let (indTree, lst) ← AddTree.indexTreeM'' t
  let arr := lst.toArray
  IndexAddTree.foldMapM indTree arr

elab "indTree#" t:term : term => do
  let e ← elabTerm t none
  let t ← addTreeM e
  AddTree.indexTreeM' t

@[simp] noncomputable def egInd {α : Type _}[AddCommGroup α][Repr α][DecidableEq α] (x y: α) :=
    indexTree# (x + y + x - y)

#print egInd

@[simp] def egInd' {α : Type _}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]  (x y: α) :=
    indTree# (x + y + x - y)

#check @egInd'
#print egInd'

@[simp] def egInd'' {α : Type _}[ag : AddCommGroup α][r : Repr α][de : DecidableEq α][w : Inhabited α]  (x y: α) : IndexAddTree × (List α)  := @egInd' α ag r de w x y

#print egInd''

@[simp] noncomputable def egIndMap {α : Type _}[AddCommGroup α][Repr α][DecidableEq α]
  (x y: α) : α  :=
        (egInd x y).fst.foldMap (egInd x y).snd.val (egInd x y).snd.property

#print egIndMap

theorem egIndMapInv{α : Type _}[AddCommGroup α][Repr α][DecidableEq α]
  (x y: α) : egIndMap x y = x + y + x - y := by
      simp
      admit

@[simp] def egIndMap'' {α : Type _}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]
  (x y: α) : α  :=
        let (tree, l) := egInd'' x y
        let arr := l.toArray
        tree.foldMap! arr

theorem egIndMapInv''{α : Type _}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]
  (x y: α) : egIndMap'' x y = x + y + x - y := by
      simp
      admit

theorem egRoundtrip{α : Type _}[AddCommGroup α][Repr α][DecidableEq α][Inhabited α]
    (x y : α) : x + y + x - y =  roundtrip# (x + y + x - y)  := by rfl

def ℤnType : Nat →  MetaM Expr
| 0 => return mkConst ``Unit
| n + 1 => do mkAppM ``Prod #[mkConst ``Int, ← ℤnType n]

#eval (ℤnType 2)


import exp.open

namespace tts ------------------------------------------------------------------
namespace exp ------------------------------------------------------------------
variables {V : Type} [decidable_eq V] -- Type of variable names
variables {k k₂ k₃ : ℕ} -- Natural numbers
variables {v : V} -- Variable names
variables {x : tagged V} -- Variables
variables {e ea eb ed ef e₁ e₂ e₃ : exp V} -- Expressions

open occurs

/-- Locally-close expression -/
inductive lc : exp V → Prop
| var  : Π x,                                                                                lc (var free x)
| app  : Π                {ef ea : exp V},              lc ef → lc ea →                                          lc (app ef ea)
| lam  : Π {v} (L : finset (tagged V)) {eb : exp V},            (∀ {x : tagged V}, x ∉ L → lc (open_var x eb)) → lc (lam v eb)
| let_ : Π {v} (L : finset (tagged V)) {ed eb : exp V}, lc ed → (∀ {x : tagged V}, x ∉ L → lc (open_var x eb)) → lc (let_ v ed eb)

/-- Locally-closed body of a lambda- or let-expression -/
def lc_body (e : exp V) : Prop :=
∃ (L : finset (tagged V)), ∀ {x : tagged V}, x ∉ L → lc (open_var x e)

@[simp] theorem lc_var (x : tagged V) : lc (var free x) :=
lc.var x

@[simp] theorem lc_app : lc (app ef ea) ↔ lc ef ∧ lc ea :=
⟨λ l, by cases l with _ _ _ l₁ l₂; exact ⟨l₁, l₂⟩, λ ⟨l₁, l₂⟩, lc.app l₁ l₂⟩

@[simp] theorem lc_lam : lc (lam v eb) ↔ lc_body eb :=
⟨λ l, by cases l; apply exists.intro; assumption; assumption,
 λ l, by cases l; apply lc.lam; assumption; assumption⟩

@[simp] theorem lc_let_ : lc (let_ v ed eb) ↔ lc ed ∧ lc_body eb :=
⟨λ l, by cases l; exact ⟨by assumption, ⟨by assumption, by assumption⟩⟩,
 by rintro ⟨_, _, _⟩; apply lc.let_; repeat {assumption}⟩

theorem open_exp_of_lc_aux (p : k₂ ≠ k₃) :
  open_exp e₂ k₂ (open_exp e₃ k₃ e₁) = open_exp e₃ k₃ e₁ → open_exp e₂ k₂ e₁ = e₁ :=
begin
  induction e₁ generalizing e₂ e₃ k₂ k₃; repeat {rw open_exp},
  case exp.var : o x {
    cases o,
    case occurs.bound {
      cases x with _ i,
      by_cases h : k₃ = i,
      { induction h, simp [p] },
      { simp [h] } },
    case occurs.free { exact id }, },
  case exp.app : ef ea ihf iha {
    intro h,
    injection h with hf ha,
    conv {to_lhs, rw [ihf p hf, iha p ha]} },
  case exp.lam : v eb rb {
    intro h,
    injection h with _ hb,
    conv {to_lhs, rw rb (mt nat.succ.inj p) hb} },
  case exp.let_ : v ed eb rd rb {
    intro h,
    injection h with _ hd hb,
    conv {to_lhs, rw [rd p hd, rb (mt nat.succ.inj p) hb]} }
end

@[simp] theorem open_exp_id (l : lc e₁) : open_exp e₂ k e₁ = e₁ :=
begin
  induction l generalizing e₂ k; rw open_exp,
  case lc.app : ef ea lf la rf ra { rw [rf, ra] },
  case lc.lam : v L eb lb rb {
    rw open_exp_of_lc_aux k.succ_ne_zero (rb ((fresh.tagged v).gen_not_mem L)) },
  case lc.let_ : v L ed eb ld Fb rd rb {
    rw [rd, open_exp_of_lc_aux k.succ_ne_zero (rb ((fresh.tagged v).gen_not_mem L))] }
end

end /- namespace -/ exp --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------


import data.real.sqrt
import data.real.sign
import linear_algebra.matrix.is_diag
import analysis.inner_product_space.basic
import radial_isotropic
import psd
import perturbation
import analysis.special_functions.pow
import majorization
import arithmetic_bounds
import data.real.nnreal

open_locale big_operators matrix

variables {n d: ℕ} (hnd : (n : ℝ) * (d : ℝ) ≠ (0 : ℝ))
variables {V : matrix (fin d) (fin n) ℝ} {ε : ℝ}
variables {v : (fin n) → ℝ}

def to_pi (f : ℕ → ℝ) : (fin n → ℝ) := λ i, f i

def to_N_to_R (f : fin n → ℝ) : ℕ → ℝ := λ i, if h : i < n then (f (fin.mk i h)) else 0

lemma to_N_to_R_to_to_pi (f : fin n → ℝ) : to_pi (to_N_to_R f) = f :=
begin
  ext,
  rw to_N_to_R,
  rw to_pi,
  simp only [dite_eq_ite, dif_ctx_congr, fin.mk_eq_subtype_mk, fin.eta, ite_eq_left_iff],
  intro h,
  exfalso,
  exact h (subtype.prop x),
end

noncomputable instance fro : has_norm (matrix (fin d) (fin n) ℝ) :=
{
  norm := λ M, real.sqrt(∑ j : fin n, ∑ i : fin d, M i j^2),
}

noncomputable instance : has_norm (fin n → ℝ) :=
{
  norm := λ v, real.sqrt(∑ j : fin n, |v j|^2 ),
}

instance : has_inner ℝ (fin n → ℝ) :=
{
  inner := λ u v, ∑ i : fin n, (u i) * (v i)
}

lemma norm_is_euclidean (v : fin n → ℝ) : ∥ v ∥^2 = ⟪ v , v ⟫_ℝ :=
begin
  simp only [norm, inner],
  rw real.sq_sqrt,
  congr,
  ext,
  simp only [pow_bit0_abs],
  simp_rw [sq, ← real.coe_nnabs, sq, ← nnreal.coe_mul, ← nnreal.coe_sum],
  exact nnreal.coe_nonneg _,
end

notation `⟪`x`, `y`⟫` := @inner ℝ _ _ x y

-- Uᵀ : fin n → fin d → ℝ
/-- U is the collection of vectors that are an almost ε parseval frame: -/
def is_parseval_frame (U : matrix (fin d) (fin n) ℝ) : Prop :=
  (outers U = 1) ∧ (∀ j : (fin n), ∥ Uᵀ j ∥^2 = d / n)

def is_eps_parseval_frame (U : matrix (fin d) (fin n) ℝ) (ε : ℝ) : Prop :=
  ((1 + ε) • 1 ≥ outers U ∧ outers U ≥ (1 - ε) • 1) ∧ (∀ j, (1 - ε) * d / n ≤ ∥ Uᵀ j ∥^2 ∧ ∥ Uᵀ j ∥^2 ≤ (1 + ε) * d / n)

/-- Finds a nearby Parseval Frame as given in the proof, Paulsen made simple: -/

noncomputable def nearby_parseval_frame {ε : ℝ} (hε : ε > 0) (V : matrix (fin d) (fin n) ℝ)
  (hV : is_eps_parseval_frame V ε) : matrix (fin d) (fin n) ℝ :=
begin
  let V_norm := (real.sqrt(d / n)) • norm_columns(V),
  let η := perturbations ε V_normᵀ,
  let U := V_norm + ηᵀ,

  have h1 : ∀ i : fin n, ∥ Uᵀ i - Vᵀ i ∥^2 ≤
    (real.sqrt(d / n) - real.sqrt((1 - ε) * d / n))^2 + ∥ η i ∥^2 + 2 * ∥ η i ∥ :=
  begin
    sorry
  end,
  have h2 : ∀ i : fin n, ∥ Uᵀ i - Vᵀ i ∥^2 ≤
    ε * d / n :=
  begin
    sorry
  end,
  have h3 : is_eps_parseval_frame U (4 * ε) :=
  begin
    sorry
  end,
  have h4 : ∀ f : fin d → (fin n), function.injective f → linear_independent ℝ (λ i : fin d, Uᵀ (f i)) :=
  begin
    intros f hf,
    have hU := perturbations_apply ε V_normᵀ hf,
    suffices : (λ i : fin d, V_normᵀ (f i) + η (f i)) = λ i, Uᵀ (f i),
    rw ← this,
    exact hU,
    funext x,
    change V_normᵀ (f x) + η (f x) = (V_norm + ηᵀ)ᵀ (f x),
    rw matrix.transpose_add,
    rw matrix.transpose_transpose,
    exact (pi.add_apply (V_normᵀ) (η) (f x)).symm,
  end,

  let A := make_radial_isotropic U h4,
  have hA : radial_isotropic (A ⬝ U) := make_radial_isotropic_apply U h4,

  --need SVD to show these results (will also use orthogonal_radial_isotropic_radial_isotropic)
  let A' : matrix (fin d) (fin d) ℝ := sorry,
  have hA' : radial_isotropic (A' ⬝ U) := sorry,
  have hA'_diag : A'.is_diag := sorry,

  exact real.sqrt (d / n) • norm_columns (A' ⬝ U),
end

noncomputable def V_norm (V : matrix (fin d) (fin n) ℝ) := (real.sqrt(d / n)) • norm_columns(V)
noncomputable def η (ε : ℝ) (V : matrix (fin d) (fin n) ℝ): fin n → fin d → ℝ := perturbations ε (V_norm V)ᵀ
noncomputable def U (ε : ℝ) (V : matrix (fin d) (fin n) ℝ):= (V_norm V) + (η ε V)ᵀ

lemma bound_1 {ε : ℝ} (hnd : (n : ℝ) * d ≠ 0) (V : matrix (fin d) (fin n) ℝ)
  (hV : is_eps_parseval_frame V ε) : ∀ i : fin n, ∥ (U ε V)ᵀ i - Vᵀ i ∥^2 ≤
    (real.sqrt(d / n) - real.sqrt((1 - ε) * d / n))^2 + ∥ η ε V i ∥^2 + 2 * ∥ η ε V i ∥ :=
begin
  intro i,
  -- have h1 : ∥ η ε V i ∥₂^2 ≤ ε :=
  --   calc ∥ η ε V i ∥₂^2 = ∥ perturbations ε (V_norm V)ᵀ i ∥₂^2 : by {congr}
  --     ...         ≤ ε : perturbations_bound ε (V_norm V)ᵀ i,
  rw [← real_inner_self_eq_norm_sq],

  rw [real_inner_sub_sub_self, real_inner_self_eq_norm_sq, real_inner_self_eq_norm_sq],
  simp only [U],
  rw [matrix.transpose_add, pi.add_apply, matrix.transpose_transpose, to_euclidean.map_add],
  have h2 := (norm_add_le (to_euclidean ((V_norm V)ᵀ i)) (to_euclidean (η ε V i))),
  rw ← abs_eq_self.2 (norm_nonneg (to_euclidean ((V_norm V)ᵀ i) + to_euclidean ((η ε V i)))) at h2,
  rw ← abs_eq_self.2 (add_nonneg (norm_nonneg (to_euclidean ((V_norm V)ᵀ i) )) _) at h2,
  have h3 := sq_le_sq h2,
  clear h2,
  suffices : (∥ ((V_norm V)ᵀ i) ∥ + ∥(η ε V i) ∥)^2
    - 2 * ⟪ ((V_norm V)ᵀ i) + (η ε V i), (Vᵀ i)⟫ + ∥ (Vᵀ i) ∥^2 ≤
    (real.sqrt(d / n) - real.sqrt((1 - ε) * d / n))^2 + ∥ to_euclidean (η ε V i) ∥^2 + 2 * ∥ to_euclidean (η ε V i) ∥,
    { apply (le_trans _ this),
    apply add_le_add,
    apply sub_le_sub,
    exact h3,
    exact le_refl _,
    exact le_refl _,
    },
  rw add_sq,
  simp only [V_norm],
  rw matrix.transpose_smul,
  rw pi.smul_apply,
  rw to_euclidean.map_smul,
  rw norm_smul,
  rw norm_columns_apply,

end,

theorem nearby_parseval_frame_is_parseval {ε : ℝ} (hnd : (n : ℝ) * d ≠ 0) (V : matrix (fin d) (fin n) ℝ)
  (hV : is_eps_parseval_frame V ε) : is_parseval_frame (nearby_parseval_frame V hV) :=
begin

  have h1 : ∀ i : fin n, ∥ (U ε V)ᵀ i - Vᵀ i ∥₂^2 ≤
    (real.sqrt(d / n) - real.sqrt((1 - ε) * d / n))^2 + ∥ η ε V i ∥₂^2 + 2 * ∥ η ε V i ∥₂ := bound_1 hnd V hV,

  have h2 : ∀ i : fin n, ∥ Uᵀ i - Vᵀ i ∥^2 ≤
    ε * d / n :=
  begin
    sorry
  end,
  have h3 : is_eps_parseval_frame U (4 * ε) :=
  begin
    sorry
  end,
  have h4 : ∀ f : fin d → (fin n), function.injective f → linear_independent ℝ (λ i : fin d, Uᵀ (f i)) :=
  begin
    intros f hf,
    have hU := perturbations_apply ε V_normᵀ hf,
    suffices : (λ i : fin d, V_normᵀ (f i) + η (f i)) = λ i, Uᵀ (f i),
    rw ← this,
    exact hU,
    funext x,
    change V_normᵀ (f x) + η (f x) = (V_norm + ηᵀ)ᵀ (f x),
    rw matrix.transpose_add,
    rw matrix.transpose_transpose,
    exact (pi.add_apply (V_normᵀ) (η) (f x)).symm,
  end,

  let A := make_radial_isotropic U h4,
  have hA : radial_isotropic (A ⬝ U) := make_radial_isotropic_apply U h4,

  -- need SVD to show these results (will also use orthogonal_radial_isotropic_radial_isotropic)
  -- A puts U in radial isotropic position
  -- A = D Σ Eᵀ , so D Σ Eᵀ U is radial isotropic
  -- Σ U is radial isotropic
  -- Maybe reinterpet without matrices?
  let A' : matrix (fin d) (fin d) ℝ := sorry,
  have hA' : radial_isotropic (A' ⬝ U) := sorry,
  have hA'_diag : A'.is_diag := sorry,

  let W := real.sqrt (d / n) • norm_columns (A' ⬝ U),
  have def_W : ∀ i : fin n, Wᵀ i = real.sqrt (d / n) • (norm_columns (A' ⬝ U))ᵀ i := sorry,

  change is_parseval_frame W,
  rw is_parseval_frame,
  split,
  rw outers,
  rw radial_isotropic at hA',
  rw outers at hA',
  simp_rw [def_W],
  simp_rw [outer_outer_smul, outer_smul_outer],
  have nd_nonneg : 0 ≤ ((d / n) : ℝ) := sorry,
  simp_rw [smul_smul, real.mul_self_sqrt nd_nonneg],
  rw ← finset.smul_sum,
  rw hA',
  rw smul_smul,
  field_simp,
  rw mul_comm,
  rw div_self hnd,
  rw one_smul,

  intro j,
  rw def_W j,
  rw norm_smul,
  rw sq,
  rw norm_columns_apply (A' ⬝ U) j,
  rw mul_one,
  rw real.norm_eq_abs,
  rw ← abs_mul,
  rw real.mul_self_sqrt,
  rw abs_eq_self,
  apply div_nonneg,
  exact nat.cast_nonneg d,
  exact nat.cast_nonneg n,
  apply div_nonneg,
  exact nat.cast_nonneg d,
  exact nat.cast_nonneg n,

end

noncomputable def W' (U : matrix (fin d) (fin n) ℝ) (M : matrix (fin d) (fin d) ℝ) :
  matrix (fin d) (fin n) ℝ :=
  λ i j, ((∥ Uᵀ j ∥ / ∥ M.mul_vec (Uᵀ j) ∥) * (M.mul_vec (Uᵀ j) i))

-- Note, u^2 means u squared entrywise
lemma w'_sq_maj_u_sq {ε γ' : ℝ} {U W: matrix (fin d) (fin n) ℝ} {M : matrix (fin d) (fin d) ℝ}
  (hU : is_eps_parseval_frame U (4 * ε)) (hM : M.is_diag) (hM' : radial_isotropic (M ⬝ U))
  (hM'' : ∀ i j : fin d, i ≥ j → M i i ≥ M j j)
  (hU' : ∀ i : fin n, (1 - γ') * (d / n) ≤ ∥ Uᵀ i ∥^2 ∧ ∥ Uᵀ i ∥^2 ≤ (1 + γ') * (d / n)) :
  ∀ i : fin n,  majorizes (((W' U M)ᵀ i)^2) (Uᵀ i) :=
begin
  sorry,
end

lemma dist_U_W'_bound {ε γ' : ℝ} {U W: matrix (fin d) (fin n) ℝ} {M : matrix (fin d) (fin d) ℝ}
  (hU : is_eps_parseval_frame U (4 * ε)) (hM : M.is_diag) (hM' : radial_isotropic (M ⬝ U))
  (hM'' : ∀ i j : fin d, i ≥ j → M i i ≥ M j j) (hM''' : ∀ i : fin d, M i i ≥ 0)
  (hU' : ∀ i : fin n, (1 - γ') * (d / n) ≤ ∥ Uᵀ i ∥^2 ∧ ∥ Uᵀ i ∥^2 ≤ (1 + γ') * (d / n)) :
  ∥ U - (W' U M) ∥^2 ≤ 4 * ε * d^2 + γ' * d^2 :=
begin
  calc ∥ U - (W' U M) ∥^2 = ∑ j : fin n, ∑ i : fin d, ((U i j - (W' U M) i j)^2) : by
  { simp only [norm], rw real.sq_sqrt, congr,
  conv_rhs {
    congr,
    skip,
    funext,

  }
  }
  ... ≤ 4 * ε * d^2 + γ' * d^2 : by {},

end

lemma dist_U_W_bound {ε γ' : ℝ} {U W: matrix (fin d) (fin n) ℝ} {M : matrix (fin d) (fin d) ℝ}
  (hU : is_eps_parseval_frame U (4 * ε)) (hM : M.is_diag) (hM' : radial_isotropic (M ⬝ U))
  (hW : W = real.sqrt (d / n) • norm_columns (M ⬝ U))
  (hU' : ∀ i : fin n, (1 - γ') * (d / n) ≤ ∥ Uᵀ i ∥^2 ∧ ∥ Uᵀ i ∥^2 ≤ (1 + γ') * (d / n)) :
  ∥ U - W ∥^2 ≤ 8 * ε * d^2 + 4 * γ' * d^2 :=
begin
  sorry,

end

theorem nearby_parseval_frame_apply_is_nearby {ε : ℝ} (U : matrix (fin d) (fin n) ℝ)
  (hU : is_eps_parseval_frame U ε) :
    ∥ U - nearby_parseval_frame U hU ∥^2 ≤ 20 * ε * d :=
begin
  sorry
end


import tactic
import tactic.induction
import data.option.basic
import ..mcrl2

open mcrl2

variables {α : Type}

variables [comm_semigroup_with_zero α]

/- The seq' operator is used in the rule for x ⬝ y in order to identify the cases for x terminating and not terminating.-/
def seq' : option (mcrl2 α) → mcrl2 α → option (mcrl2 α)
| none y := y
| (some x) y := x ⬝ y

@[simp] lemma seq'_none_coe (y : mcrl2 α) : seq' none (y : mcrl2 α) = y := rfl
@[simp] lemma seq'_coe_coe (x y : mcrl2 α) : seq' (x : option (mcrl2 α)) y = x ⬝ y := rfl

/- The par' operator is used in rules on parallel operators (which include ||, |_ and |)
 to identify all the cases for terminating and not terminating processes.-/
def par' : option (mcrl2 α) → option (mcrl2 α) → option (mcrl2 α)
| none none := none
| (some x) none := x
| none (some y) := y
| (some x) (some y) := x || y -- or `x |_ y + y |_ x + x ∣ y`

@[simp] lemma par'_none_none : (par' none none : option (mcrl2 α)) = none := rfl
@[simp] lemma par'_coe_none (x : mcrl2 α) : par' (x : option (mcrl2 α)) none = x := rfl
@[simp] lemma par'_none_coe (y : mcrl2 α) : par' none (y : option (mcrl2 α)) = y := rfl
@[simp] lemma par'_coe_coe (x y : mcrl2 α) : par' (x : option (mcrl2 α)) y = x || y := rfl

/- The main definition of transitions. -/
inductive transition
: mcrl2 α → α → option (mcrl2 α) → Prop
| atom {a} (h : a ≠ 0) : transition (atom a) a none
| altl {x y z a} (h : transition x a z) :
  transition (x + y) a z
| altr {x y z a} (h : transition y a z) :
  transition (x + y) a z
| sum {β : Type} {f : β → mcrl2 α} {a' z a A} (ha' : a' ∈ A) (h : transition (f a') a z) :
  transition (sum A f) a z
| seq {x y z a} (h : transition x a z) : transition (x ⬝ y) a (seq' z y)
| encap_pass {x y A} {a : α} (h₁ : a ∉ A) (h₂: transition x a y) :
  transition (encap A x) a (encap A <$> y)
| par_l {x x' y a} (h : transition x a x') : transition (x || y) a (par' x' y)
| par_r {x y y' a} (h : transition y a y') : transition (x || y) a (par' x y')
| par_comm {x y x' y' a b} (h₁ : transition x a x')
  (h₂ : transition y b y') (h₃ : a * b ≠ 0) :
  transition (x || y) (a * b) (par' x' y')
| parl {x x' y a} (h : transition x a x') : transition (x |_ y) a (par' x' y)
| comm {x y x' y' a b}  (h₁ : transition x a x')
  (h₂ : transition y b y') (h₃ : a * b ≠ 0) :
  transition (x ∣ y) (a * b) (par' x' y')


import ring_theory.graded_algebra.basic
import module_localisation.basic
import lemmas.about_direct_sum

section

open_locale direct_sum big_operators

variables {ι R A : Type*}
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝓐 : ι → submodule R A) [graded_algebra 𝓐]
variables {M : Type*} [add_comm_monoid M] [module A M]
variables (𝓜 : ι → add_submonoid M)

class graded_module :=
(decompose' : M → ⨁ i, 𝓜 i)
(left_inv : function.left_inverse decompose' (direct_sum.coe_add_monoid_hom 𝓜))
(right_inv : function.right_inverse decompose' (direct_sum.coe_add_monoid_hom 𝓜))
(smul_mem : ∀ ⦃i j : ι⦄ {a : A} {m : M} (hi : a ∈ 𝓐 i) (hj : m ∈ 𝓜 j), a • m ∈ 𝓜 (i + j))

namespace graded_module

variables [graded_module 𝓐 𝓜]

protected lemma is_internal : direct_sum.is_internal 𝓜 :=
{ left := (@graded_module.left_inv ι R A _ _ _ _ _ 𝓐 _ M _ _ 𝓜 _).injective,
  right := (@graded_module.right_inv ι R A _ _ _ _ _ 𝓐 _ M _ _ 𝓜 _).surjective }

def decompose : M ≃+ ⨁ i, 𝓜 i := add_equiv.symm
{ to_fun := direct_sum.coe_add_monoid_hom 𝓜,
  inv_fun := graded_module.decompose' 𝓐,
  left_inv := graded_module.left_inv,
  right_inv := graded_module.right_inv,
  map_add' := λ x y, by rw map_add }

@[simp] lemma decompose_symm_of {i : ι} (x : 𝓜 i) :
  (graded_module.decompose 𝓐 𝓜).symm (direct_sum.of _ i x) = x :=
direct_sum.coe_add_monoid_hom_of _ _ _

instance self : graded_module 𝓐 (λ i, (𝓐 i).to_add_submonoid) :=
{ decompose' := graded_algebra.decompose 𝓐,
  left_inv := graded_algebra.left_inv,
  right_inv := graded_algebra.right_inv,
  smul_mem := λ i j x y hi hj, set_like.graded_monoid.mul_mem hi hj }

@[simp] lemma decompose_coe {i : ι} (x : 𝓜 i) :
  graded_module.decompose 𝓐 𝓜 x = direct_sum.of _ i x :=
by rw [← decompose_symm_of 𝓐 𝓜, add_equiv.apply_symm_apply]

lemma decompose_of_mem {x : M} {i : ι} (hx : x ∈ 𝓜 i) :
  graded_module.decompose 𝓐 𝓜 x = direct_sum.of _ i (⟨x, hx⟩ : 𝓜 i) :=
graded_module.decompose_coe _ _ ⟨x, hx⟩

lemma decompose_of_mem_ne {x : M} {i j : ι} (hx : x ∈ 𝓜 i) (hij : i ≠ j):
  (graded_module.decompose 𝓐 𝓜 x j : M) = 0 :=
by rw [graded_module.decompose_of_mem _ _ hx, direct_sum.of_eq_of_ne _ _ _ _ hij, add_submonoid.coe_zero]

def twisted_by (i : ι) : ι → add_submonoid M := λ j, 𝓜 (j + i)

end graded_module

end

namespace graded_module

open_locale direct_sum big_operators

variables {ι R A : Type*}
variables [decidable_eq ι] [add_group ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝓐 : ι → submodule R A) [graded_algebra 𝓐]
variables {M : Type*} [add_comm_monoid M] [module A M]
variables (𝓜 : ι → add_submonoid M) [graded_module 𝓐 𝓜]

namespace twisted_by

variables (i : ι)

def to_twisted_by : (⨁ j, 𝓜 j) →+ (⨁ j, twisted_by 𝓜 i j) :=
direct_sum.to_add_monoid $ λ j,
{ to_fun := λ m, direct_sum.of _ (j - i) begin
    refine ⟨m.1, _⟩,
    convert m.2,
    dunfold twisted_by,
    rw sub_add_cancel,
  end,
  map_zero' := begin
    generalize_proofs h,
    have : (⟨(0 : 𝓜 j), h⟩ : twisted_by 𝓜 i (j - i)) = 0,
    { ext, refl, },
    erw this,
    rw [map_zero],
  end,
  map_add' := λ x y, begin
    generalize_proofs hadd hx hy,
    have : (⟨(x + y).1, hadd⟩ : twisted_by 𝓜 i (j - i)) = ⟨x.1, hx⟩ + ⟨y.1, hy⟩,
    { ext, refl },
    erw this,
    rw [map_add],
  end }

lemma to_twisted_by.apply_of {k : ι} (x : 𝓜 k) :
  to_twisted_by 𝓜 i (direct_sum.of _ k x) =
  direct_sum.of _ (k - i) begin
    refine ⟨x.1, _⟩,
    convert x.2,
    dunfold twisted_by,
    rw sub_add_cancel,
  end := by { rw [to_twisted_by, direct_sum.to_add_monoid_of], refl }

def to_untwisted : (⨁ j, twisted_by 𝓜 i j) →+ (⨁ j, 𝓜 j) :=
direct_sum.to_add_monoid $ λ j,
{ to_fun := λ m, direct_sum.of _ (j + i) $ by exact m,
  map_zero' := by rw map_zero,
  map_add' := λ _ _, by rw map_add }

lemma to_untwisted.apply_of {k : ι} (x : twisted_by 𝓜 i k) :
  to_untwisted 𝓜 i (direct_sum.of _ k x) =
  direct_sum.of _ (k + i) (by exact x) := by { rw [to_untwisted, direct_sum.to_add_monoid_of], refl }

lemma to_untwisted.left_inv : function.left_inverse (to_untwisted 𝓜 i) (to_twisted_by 𝓜 i) :=
begin
  intros x,
  induction x using direct_sum.induction_on with j x x y hx hy,
  { rw [map_zero, map_zero] },
  { rw [to_twisted_by.apply_of, to_untwisted.apply_of],
    apply direct_sum.of_congr,
    work_on_goal 2
    { rw sub_add_cancel, },
    { simp only [sub_add_cancel, subtype.val_eq_coe, eq_mp_eq_cast, set_coe_cast, set_like.eta], } },
  { rw [map_add, map_add, hx, hy], },
end

lemma to_untwisted.right_inv : function.right_inverse (to_untwisted 𝓜 i) (to_twisted_by 𝓜 i) :=
begin
  intros x,
  induction x using direct_sum.induction_on with j x x y hx hy,
  { rw [map_zero, map_zero] },
  { rw [to_untwisted.apply_of, to_twisted_by.apply_of],
    apply direct_sum.of_congr,
    work_on_goal 2
    { rw add_sub_cancel, },
    { simp only [add_sub_cancel, subtype.val_eq_coe, eq_mp_eq_cast, set_coe_cast, set_like.eta], } },
  { rw [map_add, map_add, hx, hy], },
end

def untwisted_equiv_twisted : (⨁ j, 𝓜 j) ≃+ (⨁ j, twisted_by 𝓜 i j) :=
{ to_fun := to_twisted_by _ _,
  inv_fun := to_untwisted _ _,
  left_inv := to_untwisted.left_inv _ _,
  right_inv := to_untwisted.right_inv _ _,
  map_add' := λ x y, by rw [map_add] }

lemma smul_mem' ⦃j k : ι⦄ {a : A} {m : M} (hj : a ∈ 𝓐 j) (hk : m ∈ (twisted_by 𝓜 i k)) :
  a • m ∈ twisted_by 𝓜 i (j + k) :=
have hm : m ∈ 𝓜 (k + i), from hk,
begin
  have := graded_module.smul_mem hj hm,
  convert this using 1,
  dunfold twisted_by,
  rw [add_assoc],
end

def decompose : M ≃+ (⨁ (j : ι), (twisted_by 𝓜 i j)) :=
  add_equiv.trans (graded_module.decompose 𝓐 𝓜) (untwisted_equiv_twisted 𝓜 i)

protected lemma decompose_of_mem' {j : ι} {x : M} (hx : x ∈ 𝓜 (j + i)) :
  decompose 𝓐 𝓜 i x = direct_sum.of _ j (⟨x, hx⟩ : twisted_by 𝓜 i j) :=
begin
  dunfold decompose,
  simp only [add_equiv.trans_apply],
  apply_fun (untwisted_equiv_twisted 𝓜 i).symm,
  change _ = to_untwisted 𝓜 i (direct_sum.of _ j _),
  rw [to_untwisted.apply_of, add_equiv.symm_apply_apply, graded_module.decompose_of_mem],
  work_on_goal 2 { exact hx },
  refl,
end

lemma left_inv.of (j : ι) (x : twisted_by 𝓜 i j) :
  (twisted_by.decompose 𝓐 𝓜 i)
    (direct_sum.coe_add_monoid_hom (twisted_by 𝓜 i) (direct_sum.of _ j x)) =
  direct_sum.of _ j x :=
begin
  ext1 k,
  simp only [direct_sum.coe_add_monoid_hom_of],
  rw twisted_by.decompose_of_mem' 𝓐 𝓜 i (by convert x.2 : (x : M) ∈ 𝓜 (j + i)),
  congr' 2,
  ext,
  refl,
end

lemma right_inv.mem (j : ι) (x : M) (hj : x ∈ 𝓜 j) :
  (direct_sum.coe_add_monoid_hom (twisted_by 𝓜 i))
    ((twisted_by.decompose 𝓐 𝓜 i) x) = x :=
begin
  rw twisted_by.decompose_of_mem',
  work_on_goal 3 { exact j - i, },
  work_on_goal 2 { convert hj, rw sub_add_cancel, },
  erw [direct_sum.coe_add_monoid_hom, direct_sum.to_add_monoid_of],
  refl,
end

end twisted_by

instance twisted_by_module (i : ι) : graded_module 𝓐 (twisted_by 𝓜 i) :=
have m : ∀ x, x ∈ supr 𝓜,
from λ x, (direct_sum.is_internal.add_submonoid_supr_eq_top _ (graded_module.is_internal 𝓐 𝓜)).symm ▸ trivial,
{ decompose' := twisted_by.decompose 𝓐 𝓜 i,
  left_inv := λ x, direct_sum.induction_on x (by simp only [map_zero]) begin
    intros j x,
    apply twisted_by.left_inv.of,
  end (λ x y hx hy, by simp only [map_add, hx, hy]),
  right_inv := λ x, add_submonoid.supr_induction 𝓜 (m x) (twisted_by.right_inv.mem 𝓐 𝓜 i) (by simp only [map_zero]) (λ _ _ hx hy, by simp only [map_add, hx, hy]),
  smul_mem := twisted_by.smul_mem' 𝓐 𝓜 i }

instance internal.has_scalar (i : ι) : has_scalar A (⨁ j, twisted_by 𝓜 i j) :=
{ smul := λ a z, graded_module.decompose 𝓐 (twisted_by 𝓜 i) (a • (graded_module.decompose 𝓐 (twisted_by 𝓜 i)).symm z) }

lemma internal.one_smul (i : ι) (z : ⨁ j, twisted_by 𝓜 i j) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) (1 : A) z = z :=
begin
  change graded_module.decompose _ _ _ = _,
  rw [one_smul, add_equiv.apply_symm_apply],
end

lemma internal.smul_add (i : ι) (a : A) (x y : ⨁ j, twisted_by 𝓜 i j) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a (x + y) =
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a x +
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a y :=
begin
  change graded_module.decompose _ _ _ = graded_module.decompose _ _ _ + graded_module.decompose _ _ _,
  simp only [map_add, smul_add],
end

lemma internal.smul_zero (i : ι) (a : A) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a 0 = 0 :=
begin
  change graded_module.decompose _ _ _ = _,
  simp only [map_zero, smul_zero],
end

lemma internal.add_smul (i : ι) (a b : A) (x : ⨁ j, twisted_by 𝓜 i j) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) (a + b) x =
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a x +
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) b x :=
begin
  change graded_module.decompose _ _ _ = graded_module.decompose _ _ _ + graded_module.decompose _ _ _,
  simp only [map_add, add_smul],
end

lemma internal.zero_smul (i : ι) (x : ⨁ j, twisted_by 𝓜 i j) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) 0 x = 0 :=
begin
  change graded_module.decompose _ _ _ = _,
  simp only [zero_smul, map_zero],
end

lemma internal.mul_smul_of_of (i : ι) {j j' : ι} {a b : A} (hj : a ∈ 𝓐 j) (hj' : b ∈ 𝓐 j')
  (x : ⨁ j, twisted_by 𝓜 i j) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) (a * b) x =
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a
    (@has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) b x) :=
begin
  change graded_module.decompose _ _ _ = graded_module.decompose _ _ _,
  unfold has_scalar.smul,
  rw add_equiv.symm_apply_apply,
  rw mul_smul,
end

lemma internal.mul_smul (i : ι) (a b : A) (x : ⨁ j, twisted_by 𝓜 i j) :
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) (a * b) x =
  @has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) a
    (@has_scalar.smul _ _ (internal.has_scalar 𝓐 𝓜 i) b x) :=
have m : ∀ x, x ∈ supr 𝓐,
from λ x, (graded_algebra.is_internal 𝓐).submodule_supr_eq_top.symm ▸ submodule.mem_top,
begin
  change graded_module.decompose _ _ _ = graded_module.decompose _ _ _,
  rw [mul_smul],
  refine submodule.supr_induction 𝓐 (m a) _ _ _,
  { intros j a hj,
    refine submodule.supr_induction 𝓐 (m b) _ _ _,
    { intros j' b hj',
      have := internal.mul_smul_of_of 𝓐 𝓜 i hj hj' x,
      change graded_module.decompose _ _ _ = graded_module.decompose _ _ _ at this,
      rwa [mul_smul] at this, },
    { unfold has_scalar.smul,
      simp only [zero_smul, map_zero, smul_zero], },
    { unfold has_scalar.smul,
      intros b c hb hc,
      simp only [smul_add, add_smul, hb, hc, map_add], }, },
  { simp only [smul_zero, zero_smul, map_zero], },
  { intros b c hb hc,
    simp only [add_smul, smul_add, hb, hc, map_add], }
end

instance internal.is_module (i : ι) : module A (⨁ j, twisted_by 𝓜 i j) :=
{ smul := (internal.has_scalar 𝓐 𝓜 i).smul,
  one_smul := internal.one_smul _ _ _,
  mul_smul := internal.mul_smul _ _ _,
  smul_add := internal.smul_add _ _ _,
  smul_zero := internal.smul_zero _ _ _,
  add_smul := internal.add_smul _ _ _,
  zero_smul := internal.zero_smul _ _ _ }

end graded_module

namespace graded_module

open_locale direct_sum

variables {ι R A : Type*}
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝓐 : ι → submodule R A) [graded_algebra 𝓐]
variables {M : Type*} [add_comm_group M] [module A M]
variables (𝓜 : ι → add_subgroup M)

instance (i : ι) : has_neg (⨁ j, twisted_by (λ k, (𝓜 k).to_add_submonoid) i j) :=
{ neg := direct_sum.to_add_monoid begin
    intros j,
    refine { to_fun := _, map_add' := _, map_zero' := _ },
    { intros x,
      refine direct_sum.of _ j _,
      refine ⟨-x.1, _⟩,
      apply add_subgroup.neg_mem,
      exact x.2, },
    { convert map_zero _,
      rw neg_eq_zero,
      refl, },
    { intros x y,
      rw ←map_add,
      congr,
      dsimp only,
      change -(x.1 + y.1) = _,
      rw neg_add, },
  end }

instance is_add_comm_group (i : ι) : add_comm_group (⨁ j, twisted_by (λ k, (𝓜 k).to_add_submonoid) i j) :=
have aux1 : ∀ (a b c d : ⨁ j, twisted_by (λ k, (𝓜 k).to_add_submonoid) i j), a + b + (c + d) = (a + c) + (b + d), from
λ a b c d, by { rw [add_assoc, add_assoc], congr' 1, rw [←add_assoc, add_comm b c, add_assoc], },
{ neg := has_neg.neg,
  add_left_neg := λ a, begin
    change (direct_sum.to_add_monoid _) _ + a = 0,
    induction a using direct_sum.induction_on with k x x y hx hy,
    { rw [map_zero, zero_add], },
    { rw [direct_sum.to_add_monoid_of],
      simp only [add_monoid_hom.coe_mk],
      generalize_proofs h,
      rw ←map_add,
      convert map_zero _,
      rw [subtype.ext_iff_val],
      change -x.1 + x.1 = 0,
      rw add_left_neg, },
    { simp only [map_add],
      rw [aux1, hx, hy, add_zero] },
  end,
  ..(by apply_instance : add_comm_monoid (⨁ j, twisted_by (λ k, (𝓜 k).to_add_submonoid) i j))}

end graded_module