/-
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


import graphs.allexts
open function -- allows us to use key results about functions

/-
Our final two results are proving that a morphism is an isomorphism if and
only if the vertex map and edge map are both bijective.  Of course, we are
leaning very heavily on the corresponding results for functions.

You will probably want to use the definitions of left_inverse and right_inverse
and to apply the results left_inverse.injective and right_inverse.surjective.
-/
/- Lemma :
-/
lemma iso.bij {G H : graph} (α : G ↦ H) (hyp : isomorphism α) : bijective α.vertex_map ∧ bijective α.edge_map :=
begin
  sorry,

end


/-
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