import analysis.calculus.local_extr
import analysis.calculus.times_cont_diff
import analysis.calculus.iterated_deriv
import tactic data.fin
import .fin_lemmas
open set

namespace rolle_general

-- Result below thanks to Sebastien Gouezel
-- It will be added to mathlib in a more general form
lemma times_cont_diff_on_succ_iff_deriv_within_of_Ioo
    (a b : ℝ) (f : ℝ → ℝ) (n : ℕ) (hf : times_cont_diff_on ℝ (n+1) f (Ioo a b) ) :
    times_cont_diff_on ℝ n (deriv f) (Ioo a b) :=
begin
  have : deriv f = (λ u : ℝ →L[ℝ] ℝ, u 1) ∘ (fderiv ℝ f), by { ext x, refl },
  simp only [this],
  have : times_cont_diff_on ℝ n (fderiv ℝ f) (Ioo a b),
  { apply ((times_cont_diff_on_succ_iff_fderiv_within (unique_diff_on_Ioo a b)).1 hf).2.congr,
    assume x hx,
    calc fderiv ℝ f x = fderiv_within ℝ f univ x : by simp
    ... = fderiv_within ℝ f (univ ∩ Ioo a b) x :
      (fderiv_within_inter (Ioo_mem_nhds hx.1 hx.2) unique_diff_within_at_univ).symm
    ... = fderiv_within ℝ f (Ioo a b) x : by simp },
  apply times_cont_diff.comp_times_cont_diff_on _ this,
  exact (is_bounded_bilinear_map_apply.is_bounded_linear_map_left _).times_cont_diff
end

-- This constructs the sequence of points where the derivative is zero
-- given points where the function is zero (repeated standard Rolle application)
lemma exist_points_deriv (n : ℕ) (x : fin (n+2) → ℝ) (hx : strict_mono x) :
    ∀ (f : ℝ → ℝ), continuous_on f ( Icc (x 0) (x (n+1)) ) →
    (∀ i, f (x i) = 0)  →
    ∃ (xp : fin(n+1) → ℝ), strict_mono xp ∧
        ∀ (i : fin (n+1)), xp i ∈ ( Ioo (x 0) (x (n+1)) ) ∧ deriv f (xp i) = 0 :=
begin
    intros f hf hxi,
    have h1 : ∀ (i : fin (n+1)), ∃ y ∈ (Ioo (x i) (x (i+1))), deriv f y = 0,
        intro i,
        apply exists_deriv_eq_zero,
        -- show x i < x (i+1)
        exact hx (fin_lt_succ n i),
        -- show f continuous on Icc (x i) (x (i+1))
        have h02 : Icc (x i) (x (i+1)) ⊆ Icc (x 0) (x (n+1)),
            intros z hz,
            cases hz with hz1 hz2,
            split,
            have g3 := (strict_mono.le_iff_le hx).mpr (fin.zero_le i),
            linarith, -- use strict_mono x
            have g3 := (strict_mono.le_iff_le hx).mpr (fin_le_last_val n (i+1)),
            linarith,
        exact continuous_on.mono hf h02,
        -- show f (x i) = f (x (i+1))
        rw [hxi i, hxi (i+1)],
        -- this is just normal Rolle, exists_deriv_eq_zero
    choose xp hxp using h1,
    use xp, split,
    intros i j hij,
    cases (hxp i).1 with hi1 hi2, cases (hxp j).1 with hj1 hj2,
    rcases lt_trichotomy ((i+1) : fin (n+2) ) (j : fin (n+2)) with h1|h2|h3,
    -- case (i+1) < j
    have hii1 := hx h1, linarith,
    -- case (i+1) = j
    rw h2 at hi2, linarith,
    -- case j < (i+1) is not possible because i < j
    exfalso,
        have h3n : (j : ℕ) < ((i + 1) : ℕ), {
            norm_num at h3,
            change (j.val : fin (n+2)).val < (i.val.succ : fin (n+2)).val at h3,
            rwa [fin.coe_val_of_lt (show j.1 < n + 2, by linarith [j.2]),
                fin.coe_val_of_lt (show i.1 + 1 < n + 2, by linarith [i.2])] at h3,
            },
        have gf1 := nat.lt_succ_iff.mp h3n,
        --strange as it looks, linarith still needs this
        have hijn : (i : ℕ) < (j : ℕ), exact hij,
        linarith,
    intro i, split,
    swap, exact (hxp i).2,
    split,
    cases ((hxp i).1) with g01 g02,
    have := (strict_mono.le_iff_le hx).mpr (@fin.zero_le (n+1) i),
    linarith,
    cases ((hxp i).1) with g01 g02,
    have := (strict_mono.le_iff_le hx).mpr (fin_le_last_val n (i+1)),
    linarith, done
end

theorem general_rolle (n : ℕ) (x : fin (n+2) → ℝ) (hx : strict_mono x) :
    ∀ (f : ℝ → ℝ), times_cont_diff_on ℝ n f ( Icc (x 0) (x (n+1)) ) →
    (∀ i, f (x i) = 0)  →
    ∃ c ∈ Ioo (x 0) (x (n+1)), iterated_deriv (n+1) f c = 0 :=
begin
    induction n with d hd,
    { -- base case, just plain Rolle `exists_deriv_eq_zero`
        intros f hf hi,
        norm_cast at hf,
        rw times_cont_diff_on_zero at hf,
        have h1 : 0 < 1, linarith,
        -- ?? The above was needed because linarith fails on next one without it:
        have h2 : (0 : fin 2) < (1 : fin 2), exact h1, -- linarith fails !!!???
        have hx01 := hx h2, clear h1, clear h2,
        have heq : f (x 0) = f (x 1), rw [hi 0, hi 1],
        have h5 := exists_deriv_eq_zero f hx01 hf heq,
        rw iterated_deriv_one,
        have g : (((0 : ℕ) + 1) : fin 2) = 1, norm_cast,
        rw g,
        exact h5,
    },
    { -- induction step
        -- the derivative is in Cᵈ
        intros f hf hi,
        have hfc := times_cont_diff_on.continuous_on hf,
        have H := exist_points_deriv d.succ x hx f hfc hi,
        --cases H with xp hxp, cases hxp with hxpx hxpi,
        rcases H with ⟨ xp, ⟨ hxpx, hxpi ⟩ ⟩,
        set g := deriv f with hg,
        have hf1 : times_cont_diff_on ℝ d.succ f (Ioo (x 0) (x (d.succ+1))),
            have hf11 : Ioo (x 0) (x (d.succ + 1)) ⊆ Icc (x 0) (x (d.succ + 1)),
                exact Ioo_subset_Icc_self,
            exact times_cont_diff_on.mono hf hf11,
        have hder0 := times_cont_diff_on_succ_iff_deriv_within_of_Ioo (x 0) (x (d.succ +1)) f d hf1,
        have hder : times_cont_diff_on ℝ d g (Icc (xp 0) (xp (d+1))),
            have hdr0 : Icc (xp 0) (xp (d+1)) ⊆ Ioo (x 0) (x (d.succ + 1)),
                intros z hz,
                cases hz with hz1 hz2,
                split,
                cases (hxpi 0).1 with h0z0 h0z1, linarith,
                cases (hxpi d.succ).1 with hdz0 hdz1,
                norm_cast at hz2, linarith,
            exact times_cont_diff_on.mono hder0 hdr0,
        have hdg := hd xp hxpx g hder, clear hd,
        have H1 : ∀ i, g (xp i) = 0,
            intro i,
            exact (hxpi i).2,
        have G := hdg H1,
        have K : iterated_deriv (d.succ + 1) f = iterated_deriv d.succ g,
            apply iterated_deriv_succ',
        rw ← K at G,
        rcases G with ⟨ c, ⟨ ⟨hc10, hc11⟩, hc2 ⟩ ⟩,
        use c,
        split, swap, exact hc2,
        have hxp0 := (hxpi 0).1, cases hxp0 with hxp01 hxp02,
        split, linarith,
        have hxp1 := (hxpi d.succ).1, cases hxp1 with hxp11 hxp12,
        have hxpeq0 : d+1 = d.succ, rw nat.succ_eq_add_one,
        have hxpeq1 : ((d+1) :  fin (d.succ + 1) ) = d.succ,
            norm_cast,
        rw hxpeq1 at hc11,
        linarith,
    },
    done
end

end rolle_general


/- Author: E.W.Ayers © 2019 -/
import ..equate
open robot
universe u
section sets
    variables {α : Type u} {X A B C : set α}
    @[equate] example : X \ (B ∩ C) = (X \ B) ∪ (X \ C) :=
    by equate
    example : ( X \ B ) ∪ ( X \ C ) = X \ ( B ∩ C ) :=
    by equate
    example : ( X \ B ) \ C = X \ ( B ∪ C ) :=
    by equate
    example : X \ ( B ∪ C ) = ( X \ B ) \ C :=
    by equate
    @[equate] def A6l : (B ∩ C) ∪ A = (B ∪ A) ∩ (C ∪ A) :=
    by equate
    @[equate] def A7l : (B ∪ C) ∩ A = (B ∩ A) ∪ (C ∩ A) :=
    by equate
    example : (A ∪ B) \ A = B \ A -- [FIXME]
    := by equate
    example : (A ∪ B) \ C = A \ C ∪ B \ C
    := by equate
    example : A \ C ∪ B \ C = (A ∪ B) \ C  -- [FIXME]
    := by equate
end sets


variable {p : Prop}

open Classical

theorem dne (h : ¬¬p) : p :=
  Or.elim (em p)
  (fun (hp : p) => hp)
  (fun (hnp: ¬p) => absurd hnp h)

theorem step (h : ¬(p ∨ ¬ p)) : ¬p :=
  fun (hp : p) => h (Or.intro_left (¬p) (hp))

theorem exclmid : p ∨ ¬p :=
  dne (
    fun (h : ¬(p ∨ ¬p)) =>
    h (Or.intro_right (p) (step h))
  )

#check dne
#check p ∨ ¬ p


import Mathbin

namespace MonomialPow

universe u

variable {R : Type u}
variable {_ : Type_}

-- variable [CommSemiringₓ R]

-- open MvPolynomial

/- Converting a single variable polynomial to a multivariable polynomial
and back yields the same polynomial
lemma monomial_pow {s : Finsupp S →₀ ℕ} {a : R} {n : ℕ} :
  monomial s a ^ n = monomial (n • s) (a ^ n) := by
  induction n
  rw [monomial_eq]
  simp
  -- rw nat.succ_eq_add_one,
  simp [pow_succ, succ_nsmul]
  rw [n_ih]
  rw [monomial_mul]
  -- library_search,
-/

end MonomialPow


variable U : Type
variables P Q R : U → Prop

example (P1: forall x,(Q x -> R x))
        (P2 : exists x,(P x /\ (not (R x)))) :
        exists x, (P x /\ (not (Q x))) :=

obtain (y:U)(H1 : (P y /\ (not (R y)))), from P2,
have H2 : (Q y -> R y), from P1 y,
have H3 : not(Q y), from (
    assume Hqy : Q y,
    show false, from (and.right H1) (H2 Hqy)
),
show exists x,(P x /\ (not (Q x))), from exists.intro y (
    and.intro (and.left H1) H3
)


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import analysis.complex.circle
import analysis.inner_product_space.calculus
import analysis.inner_product_space.pi_L2
import geometry.manifold.algebra.lie_group
import geometry.manifold.instances.real

/-!
# Manifold structure on the sphere

This file defines stereographic projection from the sphere in an inner product space `E`, and uses
it to put a smooth manifold structure on the sphere.

## Main results

For a unit vector `v` in `E`, the definition `stereographic` gives the stereographic projection
centred at `v`, a local homeomorphism from the sphere to `(ℝ ∙ v)ᗮ` (the orthogonal complement of
`v`).

For finite-dimensional `E`, we then construct a smooth manifold instance on the sphere; the charts
here are obtained by composing the local homeomorphisms `stereographic` with arbitrary isometries
from `(ℝ ∙ v)ᗮ` to Euclidean space.

We prove two lemmas about smooth maps:
* `times_cont_mdiff_coe_sphere` states that the coercion map from the sphere into `E` is smooth;
  this is a useful tool for constructing smooth maps *from* the sphere.
* `times_cont_mdiff.cod_restrict_sphere` states that a map from a manifold into the sphere is
  smooth if its lift to a map to `E` is smooth; this is a useful tool for constructing smooth maps
  *to* the sphere.

As an application we prove `times_cont_mdiff_neg_sphere`, that the antipodal map is smooth.

Finally, we equip the `circle` (defined in `analysis.complex.circle` to be the sphere in `ℂ`
centred at `0` of radius `1`) with the following structure:
* a charted space with model space `euclidean_space ℝ (fin 1)` (inherited from `metric.sphere`)
* a Lie group with model with corners `𝓡 1`

We furthermore show that `exp_map_circle` (defined in `analysis.complex.circle` to be the natural
map `λ t, exp (t * I)` from `ℝ` to `circle`) is smooth.

## Implementation notes

The model space for the charted space instance is `euclidean_space ℝ (fin n)`, where `n` is a
natural number satisfying the typeclass assumption `[fact (finrank ℝ E = n + 1)]`.  This may seem a
little awkward, but it is designed to circumvent the problem that the literal expression for the
dimension of the model space (up to definitional equality) determines the type.  If one used the
naive expression `euclidean_space ℝ (fin (finrank ℝ E - 1))` for the model space, then the sphere in
`ℂ` would be a manifold with model space `euclidean_space ℝ (fin (2 - 1))` but not with model space
`euclidean_space ℝ (fin 1)`.
-/

variables {E : Type*} [inner_product_space ℝ E]

noncomputable theory

open metric finite_dimensional
open_locale manifold

local attribute [instance] fact_finite_dimensional_of_finrank_eq_succ

section stereographic_projection
variables (v : E)

/-! ### Construction of the stereographic projection -/

/-- Stereographic projection, forward direction. This is a map from an inner product space `E` to
the orthogonal complement of an element `v` of `E`. It is smooth away from the affine hyperplane
through `v` parallel to the orthogonal complement.  It restricts on the sphere to the stereographic
projection. -/
def stereo_to_fun [complete_space E] (x : E) : (ℝ ∙ v)ᗮ :=
(2 / ((1:ℝ) - inner_right v x)) • orthogonal_projection (ℝ ∙ v)ᗮ x

variables {v}

@[simp] lemma stereo_to_fun_apply [complete_space E] (x : E) :
  stereo_to_fun v x = (2 / ((1:ℝ) - inner_right v x)) • orthogonal_projection (ℝ ∙ v)ᗮ x :=
rfl

lemma times_cont_diff_on_stereo_to_fun [complete_space E] :
  times_cont_diff_on ℝ ⊤ (stereo_to_fun v) {x : E | inner_right v x ≠ (1:ℝ)} :=
begin
  refine times_cont_diff_on.smul _
    (orthogonal_projection ((ℝ ∙ v)ᗮ)).times_cont_diff.times_cont_diff_on,
  refine times_cont_diff_const.times_cont_diff_on.div _ _,
  { exact (times_cont_diff_const.sub (inner_right v).times_cont_diff).times_cont_diff_on },
  { intros x h h',
    exact h (sub_eq_zero.mp h').symm }
end

lemma continuous_on_stereo_to_fun [complete_space E] :
  continuous_on (stereo_to_fun v) {x : E | inner_right v x ≠ (1:ℝ)} :=
times_cont_diff_on_stereo_to_fun.continuous_on

variables (v)

/-- Auxiliary function for the construction of the reverse direction of the stereographic
projection.  This is a map from the orthogonal complement of a unit vector `v` in an inner product
space `E` to `E`; we will later prove that it takes values in the unit sphere.

For most purposes, use `stereo_inv_fun`, not `stereo_inv_fun_aux`. -/
def stereo_inv_fun_aux (w : E) : E := (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v)

variables {v}

@[simp] lemma stereo_inv_fun_aux_apply (w : E) :
  stereo_inv_fun_aux v w = (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v) :=
rfl

lemma stereo_inv_fun_aux_mem (hv : ∥v∥ = 1) {w : E} (hw : w ∈ (ℝ ∙ v)ᗮ) :
  stereo_inv_fun_aux v w ∈ (sphere (0:E) 1) :=
begin
  have h₁ : 0 ≤ ∥w∥ ^ 2 + 4 := by nlinarith,
  suffices : ∥(4:ℝ) • w + (∥w∥ ^ 2 - 4) • v∥ = ∥w∥ ^ 2 + 4,
  { have h₂ : ∥w∥ ^ 2 + 4 ≠ 0 := by nlinarith,
    simp only [mem_sphere_zero_iff_norm, norm_smul, real.norm_eq_abs, abs_inv, this,
      abs_of_nonneg h₁, stereo_inv_fun_aux_apply],
    field_simp },
  suffices : ∥(4:ℝ) • w + (∥w∥ ^ 2 - 4) • v∥ ^ 2 = (∥w∥ ^ 2 + 4) ^ 2,
  { have h₃ : 0 ≤ ∥stereo_inv_fun_aux v w∥ := norm_nonneg _,
    simpa [h₁, h₃, -one_pow] using this },
  simp [norm_add_sq_real, norm_smul, inner_smul_left, inner_smul_right,
    inner_left_of_mem_orthogonal_singleton _ hw, mul_pow, real.norm_eq_abs, hv],
  ring
end

lemma times_cont_diff_stereo_inv_fun_aux : times_cont_diff ℝ ⊤ (stereo_inv_fun_aux v) :=
begin
  have h₀ : times_cont_diff ℝ ⊤ (λ w : E, ∥w∥ ^ 2) := times_cont_diff_norm_sq,
  have h₁ : times_cont_diff ℝ ⊤ (λ w : E, (∥w∥ ^ 2 + 4)⁻¹),
  { refine (h₀.add times_cont_diff_const).inv _,
    intros x,
    nlinarith },
  have h₂ : times_cont_diff ℝ ⊤ (λ w, (4:ℝ) • w + (∥w∥ ^ 2 - 4) • v),
  { refine (times_cont_diff_const.smul times_cont_diff_id).add _,
    refine (h₀.sub times_cont_diff_const).smul times_cont_diff_const },
  exact h₁.smul h₂
end

/-- Stereographic projection, reverse direction.  This is a map from the orthogonal complement of a
unit vector `v` in an inner product space `E` to the unit sphere in `E`. -/
def stereo_inv_fun (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) : sphere (0:E) 1 :=
⟨stereo_inv_fun_aux v (w:E), stereo_inv_fun_aux_mem hv w.2⟩

@[simp] lemma stereo_inv_fun_apply (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  (stereo_inv_fun hv w : E) = (∥w∥ ^ 2 + 4)⁻¹ • ((4:ℝ) • w + (∥w∥ ^ 2 - 4) • v) :=
rfl

lemma stereo_inv_fun_ne_north_pole (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  stereo_inv_fun hv w ≠ (⟨v, by simp [hv]⟩ : sphere (0:E) 1) :=
begin
  refine subtype.ne_of_val_ne _,
  rw ← inner_lt_one_iff_real_of_norm_one _ hv,
  { have hw : ⟪v, w⟫_ℝ = 0 := inner_right_of_mem_orthogonal_singleton v w.2,
    have hw' : (∥(w:E)∥ ^ 2 + 4)⁻¹ * (∥(w:E)∥ ^ 2 - 4) < 1,
    { refine (inv_mul_lt_iff' _).mpr _,
      { nlinarith },
      linarith },
    simpa [real_inner_comm, inner_add_right, inner_smul_right, real_inner_self_eq_norm_mul_norm, hw,
      hv] using hw' },
  { simpa using stereo_inv_fun_aux_mem hv w.2 }
end

lemma continuous_stereo_inv_fun (hv : ∥v∥ = 1) : continuous (stereo_inv_fun hv) :=
continuous_induced_rng (times_cont_diff_stereo_inv_fun_aux.continuous.comp continuous_subtype_coe)

variables [complete_space E]

lemma stereo_left_inv (hv : ∥v∥ = 1) {x : sphere (0:E) 1} (hx : (x:E) ≠ v) :
  stereo_inv_fun hv (stereo_to_fun v x) = x :=
begin
  ext,
  simp only [stereo_to_fun_apply, stereo_inv_fun_apply, smul_add],
  -- name two frequently-occuring quantities and write down their basic properties
  set a : ℝ := inner_right v x,
  set y := orthogonal_projection (ℝ ∙ v)ᗮ x,
  have split : ↑x = a • v + ↑y,
  { convert eq_sum_orthogonal_projection_self_orthogonal_complement (ℝ ∙ v) x,
    exact (orthogonal_projection_unit_singleton ℝ hv x).symm },
  have hvy : ⟪v, y⟫_ℝ = 0 := inner_right_of_mem_orthogonal_singleton v y.2,
  have pythag : 1 = a ^ 2 + ∥y∥ ^ 2,
  { have hvy' : ⟪a • v, y⟫_ℝ = 0 := by simp [inner_smul_left, hvy],
    convert norm_add_sq_eq_norm_sq_add_norm_sq_of_inner_eq_zero _ _ hvy' using 2,
    { simp [← split] },
    { simp [norm_smul, hv, real.norm_eq_abs, ← sq, sq_abs] },
    { exact sq _ } },
  -- two facts which will be helpful for clearing denominators in the main calculation
  have ha : 1 - a ≠ 0,
  { have : a < 1 := (inner_lt_one_iff_real_of_norm_one hv (by simp)).mpr hx.symm,
    linarith },
  have : 2 ^ 2 * ∥y∥ ^ 2 + 4 * (1 - a) ^ 2 ≠ 0,
  { refine ne_of_gt _,
    have := norm_nonneg (y:E),
    have : 0 < (1 - a) ^ 2 := sq_pos_of_ne_zero (1 - a) ha,
    nlinarith },
  -- the core of the problem is these two algebraic identities:
  have h₁ : (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 + 4)⁻¹ * 4 * (2 / (1 - a)) = 1,
  { field_simp,
    nlinarith },
  have h₂ : (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 + 4)⁻¹ * (2 ^ 2 / (1 - a) ^ 2 * ∥y∥ ^ 2 - 4) = a,
  { field_simp,
    transitivity (1 - a) ^ 2 * (a * (2 ^ 2 * ∥y∥ ^ 2 + 4 * (1 - a) ^ 2)),
    { congr,
      nlinarith },
    ring_nf },
  -- deduce the result
  convert congr_arg2 has_add.add (congr_arg (λ t, t • (y:E)) h₁) (congr_arg (λ t, t • v) h₂)
    using 1,
  { simp [inner_add_right, inner_smul_right, hvy, real_inner_self_eq_norm_mul_norm, hv, mul_smul,
      mul_pow, real.norm_eq_abs, sq_abs, norm_smul] },
  { simp [split, add_comm] }
end

lemma stereo_right_inv (hv : ∥v∥ = 1) (w : (ℝ ∙ v)ᗮ) :
  stereo_to_fun v (stereo_inv_fun hv w) = w :=
begin
  have : 2 / (1 - (∥(w:E)∥ ^ 2 + 4)⁻¹ * (∥(w:E)∥ ^ 2 - 4)) * (∥(w:E)∥ ^ 2 + 4)⁻¹ * 4 = 1,
  { have : ∥(w:E)∥ ^ 2 + 4 ≠ 0 := by nlinarith,
    have : (4:ℝ) + 4 ≠ 0 := by nlinarith,
    field_simp,
    ring },
  convert congr_arg (λ c, c • w) this,
  { have h₁ : orthogonal_projection (ℝ ∙ v)ᗮ v = 0 :=
      orthogonal_projection_orthogonal_complement_singleton_eq_zero v,
    have h₂ : orthogonal_projection (ℝ ∙ v)ᗮ w = w :=
      orthogonal_projection_mem_subspace_eq_self w,
    have h₃ : inner_right v w = (0:ℝ) := inner_right_of_mem_orthogonal_singleton v w.2,
    have h₄ : inner_right v v = (1:ℝ) := by simp [real_inner_self_eq_norm_mul_norm, hv],
    simp [h₁, h₂, h₃, h₄, continuous_linear_map.map_add, continuous_linear_map.map_smul,
      mul_smul] },
  { simp }
end

/-- Stereographic projection from the unit sphere in `E`, centred at a unit vector `v` in `E`; this
is the version as a local homeomorphism. -/
def stereographic (hv : ∥v∥ = 1) : local_homeomorph (sphere (0:E) 1) (ℝ ∙ v)ᗮ :=
{ to_fun := (stereo_to_fun v) ∘ coe,
  inv_fun := stereo_inv_fun hv,
  source := {⟨v, by simp [hv]⟩}ᶜ,
  target := set.univ,
  map_source' := by simp,
  map_target' := λ w _, stereo_inv_fun_ne_north_pole hv w,
  left_inv' := λ _ hx, stereo_left_inv hv (λ h, hx (subtype.ext h)),
  right_inv' := λ w _, stereo_right_inv hv w,
  open_source := is_open_compl_singleton,
  open_target := is_open_univ,
  continuous_to_fun := continuous_on_stereo_to_fun.comp continuous_subtype_coe.continuous_on
    (λ w h, h ∘ subtype.ext ∘ eq.symm ∘ (inner_eq_norm_mul_iff_of_norm_one hv (by simp)).mp),
  continuous_inv_fun := (continuous_stereo_inv_fun hv).continuous_on }

@[simp] lemma stereographic_source (hv : ∥v∥ = 1) :
  (stereographic hv).source = {⟨v, by simp [hv]⟩}ᶜ :=
rfl

@[simp] lemma stereographic_target (hv : ∥v∥ = 1) : (stereographic hv).target = set.univ := rfl

end stereographic_projection

section charted_space

/-!
### Charted space structure on the sphere

In this section we construct a charted space structure on the unit sphere in a finite-dimensional
real inner product space `E`; that is, we show that it is locally homeomorphic to the Euclidean
space of dimension one less than `E`.

The restriction to finite dimension is for convenience.  The most natural `charted_space`
structure for the sphere uses the stereographic projection from the antipodes of a point as the
canonical chart at this point.  However, the codomain of the stereographic projection constructed
in the previous section is `(ℝ ∙ v)ᗮ`, the orthogonal complement of the vector `v` in `E` which is
the "north pole" of the projection, so a priori these charts all have different codomains.

So it is necessary to prove that these codomains are all continuously linearly equivalent to a
fixed normed space.  This could be proved in general by a simple case of Gram-Schmidt
orthogonalization, but in the finite-dimensional case it follows more easily by dimension-counting.
-/

/-- Variant of the stereographic projection, for the sphere in an `n + 1`-dimensional inner product
space `E`.  This version has codomain the Euclidean space of dimension `n`, and is obtained by
composing the original sterographic projection (`stereographic`) with an arbitrary linear isometry
from `(ℝ ∙ v)ᗮ` to the Euclidean space. -/
def stereographic' (n : ℕ) [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  local_homeomorph (sphere (0:E) 1) (euclidean_space ℝ (fin n)) :=
(stereographic (norm_eq_of_mem_sphere v)) ≫ₕ
(linear_isometry_equiv.from_orthogonal_span_singleton n
  (nonzero_of_mem_unit_sphere v)).to_homeomorph.to_local_homeomorph

@[simp] lemma stereographic'_source {n : ℕ} [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  (stereographic' n v).source = {v}ᶜ :=
by simp [stereographic']

@[simp] lemma stereographic'_target {n : ℕ} [fact (finrank ℝ E = n + 1)] (v : sphere (0:E) 1) :
  (stereographic' n v).target = set.univ :=
by simp [stereographic']

/-- The unit sphere in an `n + 1`-dimensional inner product space `E` is a charted space
modelled on the Euclidean space of dimension `n`. -/
instance {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  charted_space (euclidean_space ℝ (fin n)) (sphere (0:E) 1) :=
{ atlas            := {f | ∃ v : (sphere (0:E) 1), f = stereographic' n v},
  chart_at         := λ v, stereographic' n (-v),
  mem_chart_source := λ v, by simpa using ne_neg_of_mem_unit_sphere ℝ v,
  chart_mem_atlas  := λ v, ⟨-v, rfl⟩ }

end charted_space

section smooth_manifold

/-! ### Smooth manifold structure on the sphere -/

/-- The unit sphere in an `n + 1`-dimensional inner product space `E` is a smooth manifold,
modelled on the Euclidean space of dimension `n`. -/
instance {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  smooth_manifold_with_corners (𝓡 n) (sphere (0:E) 1) :=
smooth_manifold_with_corners_of_times_cont_diff_on (𝓡 n) (sphere (0:E) 1)
begin
  rintros _ _ ⟨v, rfl⟩ ⟨v', rfl⟩,
  let U : (ℝ ∙ (v:E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    linear_isometry_equiv.from_orthogonal_span_singleton n
      (nonzero_of_mem_unit_sphere v),
  let U' : (ℝ ∙ (v':E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    linear_isometry_equiv.from_orthogonal_span_singleton n
      (nonzero_of_mem_unit_sphere v'),
  have hUv : stereographic' n v = (stereographic (norm_eq_of_mem_sphere v)) ≫ₕ
    U.to_homeomorph.to_local_homeomorph := rfl,
  have hU'v' : stereographic' n v' = (stereographic (norm_eq_of_mem_sphere v')).trans
    U'.to_homeomorph.to_local_homeomorph := rfl,
  have H₁ := U'.times_cont_diff.comp_times_cont_diff_on times_cont_diff_on_stereo_to_fun,
  have H₂ := (times_cont_diff_stereo_inv_fun_aux.comp
      (ℝ ∙ (v:E))ᗮ.subtypeL.times_cont_diff).comp U.symm.times_cont_diff,
  convert H₁.comp' (H₂.times_cont_diff_on : times_cont_diff_on ℝ ⊤ _ set.univ) using 1,
  have h_set : ∀ p : sphere (0:E) 1, p = v' ↔ ⟪(p:E), v'⟫_ℝ = 1,
  { simp [subtype.ext_iff, inner_eq_norm_mul_iff_of_norm_one] },
  ext,
  simp [h_set, hUv, hU'v', stereographic, real_inner_comm]
end

/-- The inclusion map (i.e., `coe`) from the sphere in `E` to `E` is smooth.  -/
lemma times_cont_mdiff_coe_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  times_cont_mdiff (𝓡 n) 𝓘(ℝ, E) ∞ (coe : (sphere (0:E) 1) → E) :=
begin
  rw times_cont_mdiff_iff,
  split,
  { exact continuous_subtype_coe },
  { intros v _,
    let U : (ℝ ∙ ((-v):E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
      linear_isometry_equiv.from_orthogonal_span_singleton n (nonzero_of_mem_unit_sphere (-v)),
    exact ((times_cont_diff_stereo_inv_fun_aux.comp
      (ℝ ∙ ((-v):E))ᗮ.subtypeL.times_cont_diff).comp U.symm.times_cont_diff).times_cont_diff_on }
end

variables {F : Type*} [normed_group F] [normed_space ℝ F]
variables {H : Type*} [topological_space H] {I : model_with_corners ℝ F H}
variables {M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-- If a `times_cont_mdiff` function `f : M → E`, where `M` is some manifold, takes values in the
sphere, then it restricts to a `times_cont_mdiff` function from `M` to the sphere. -/
lemma times_cont_mdiff.cod_restrict_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)]
  {m : with_top ℕ} {f : M → E} (hf : times_cont_mdiff I 𝓘(ℝ, E) m f)
  (hf' : ∀ x, f x ∈ sphere (0:E) 1) :
  times_cont_mdiff I (𝓡 n) m (set.cod_restrict _ _ hf' : M → (sphere (0:E) 1)) :=
begin
  rw times_cont_mdiff_iff_target,
  refine ⟨continuous_induced_rng hf.continuous, _⟩,
  intros v,
  let U : (ℝ ∙ ((-v):E))ᗮ ≃ₗᵢ[ℝ] euclidean_space ℝ (fin n) :=
    (linear_isometry_equiv.from_orthogonal_span_singleton n (nonzero_of_mem_unit_sphere (-v))),
  have h : times_cont_diff_on ℝ ⊤ U set.univ :=
    U.times_cont_diff.times_cont_diff_on,
  have H₁ := (h.comp' times_cont_diff_on_stereo_to_fun).times_cont_mdiff_on,
  have H₂ : times_cont_mdiff_on _ _ _ _ set.univ := hf.times_cont_mdiff_on,
  convert (H₁.of_le le_top).comp' H₂ using 1,
  ext x,
  have hfxv : f x = -↑v ↔ ⟪f x, -↑v⟫_ℝ = 1,
  { have hfx : ∥f x∥ = 1 := by simpa using hf' x,
    rw inner_eq_norm_mul_iff_of_norm_one hfx,
    exact norm_eq_of_mem_sphere (-v) },
  dsimp [chart_at],
  simp [not_iff_not, subtype.ext_iff, hfxv, real_inner_comm]
end

/-- The antipodal map is smooth. -/
lemma times_cont_mdiff_neg_sphere {n : ℕ} [fact (finrank ℝ E = n + 1)] :
  times_cont_mdiff (𝓡 n) (𝓡 n) ∞ (λ x : sphere (0:E) 1, -x) :=
(times_cont_diff_neg.times_cont_mdiff.comp times_cont_mdiff_coe_sphere).cod_restrict_sphere _

end smooth_manifold

section circle

open complex

local attribute [instance] finrank_real_complex_fact

/-- The unit circle in `ℂ` is a charted space modelled on `euclidean_space ℝ (fin 1)`.  This
follows by definition from the corresponding result for `metric.sphere`. -/
instance : charted_space (euclidean_space ℝ (fin 1)) circle := metric.sphere.charted_space

instance : smooth_manifold_with_corners (𝓡 1) circle :=
metric.sphere.smooth_manifold_with_corners

/-- The unit circle in `ℂ` is a Lie group. -/
instance : lie_group (𝓡 1) circle :=
{ smooth_mul := begin
    let c : circle → ℂ := coe,
    have h₁ : times_cont_mdiff _ _ _ (prod.map c c) :=
      times_cont_mdiff_coe_sphere.prod_map times_cont_mdiff_coe_sphere,
    have h₂ : times_cont_mdiff (𝓘(ℝ, ℂ).prod 𝓘(ℝ, ℂ)) 𝓘(ℝ, ℂ) ∞ (λ (z : ℂ × ℂ), z.fst * z.snd),
    { rw times_cont_mdiff_iff,
      exact ⟨continuous_mul, λ x y, (times_cont_diff_mul.restrict_scalars ℝ).times_cont_diff_on⟩ },
    exact (h₂.comp h₁).cod_restrict_sphere _,
  end,
  smooth_inv := (complex.conj_cle.times_cont_diff.times_cont_mdiff.comp
    times_cont_mdiff_coe_sphere).cod_restrict_sphere _,
  .. metric.sphere.smooth_manifold_with_corners }

/-- The map `λ t, exp (t * I)` from `ℝ` to the unit circle in `ℂ` is smooth. -/
lemma times_cont_mdiff_exp_map_circle : times_cont_mdiff 𝓘(ℝ, ℝ) (𝓡 1) ∞ exp_map_circle :=
(((times_cont_diff_exp.restrict_scalars ℝ).comp
  (times_cont_diff_id.smul times_cont_diff_const)).times_cont_mdiff).cod_restrict_sphere _

end circle


import analysis.special_functions.exp_log

noncomputable theory

open set real

section rounding

/-- Addition of affine forms with error. -/
-- TODO: Move.
def log₂ (x : ℝ) := log x / log 2

-- TODO: This should happen over the dyadic rationals.
-- Or not, but prove a lemma that there exists a dyadic that casts to the computed real.
-- TODO: Move to dyadic.
def round_down (p : ℤ) (r : ℝ) : ℝ := ⌊r * 2 ^ p⌋ * 2 ^ -p

lemma round_down_zero (p : ℤ) : round_down p 0 = 0 :=
by simp [round_down]

def round_up (p : ℤ) (r : ℝ) : ℚ := ⌈r * 2 ^ p⌉ * 2 ^ -p

-- TODO: This should be shorter.
lemma round_up_mono (p : ℤ) (x y : ℝ) (h : x ≤ y)
: round_up p x ≤ round_up p y :=
begin
  simp [round_up], refine (mul_le_mul_right _).2 _,
  { simp, exact (fpow_pos_of_pos (by linarith) p), },
  { simp, apply ceil_mono, refine (mul_le_mul_right _).2 h,
    exact fpow_pos_of_pos (by linarith) p, },
end

def truncate_down (p : ℕ) (r : ℝ) : ℝ := round_down (p - ⌊log₂ r⌋ - 1) r

lemma truncate_down_zero (p : ℕ) : truncate_down p 0 = 0 :=
by simp [truncate_down, round_down_zero]

def truncate_up (p : ℕ) (r : ℝ) : ℝ := round_up (p - ⌊log₂ r⌋ - 1) r

lemma truncate_up_mono (p : ℕ) (x y : ℝ) (h : x ≤ y)
: truncate_up p x ≤ truncate_up p x :=
by simp [truncate_up, round_up_mono]

-- We need something like ⌈a * b⌉ ≥ ⌈a⌉ * b if b ≥ 1. Then we should
-- assume that p - ⌊log₂ r⌋ ≥ 1. That is not great, it holds regardless...
lemma truncate_up_ge (p : ℕ) (r : ℝ) : r ≤ truncate_up p r :=
begin
  simp [truncate_up, round_up], sorry,
end

-- Def trunc-bound-eucl (p. 152)
def truncate_with_error (p : ℕ) (r : ℝ) : ℝ × ℝ :=
let q := truncate_down p r, e := truncate_up p (abs (q - r)) in ⟨q, e⟩

lemma truncate_with_error_is_bound (p : ℕ) (r : ℝ)
: ∃ e : ℝ, (truncate_with_error p r).1 = r + e ∧ abs e ≤ (truncate_with_error p r).2 :=
begin
  use [truncate_down p r - r], split,
  { ring, },
  { simp [truncate_with_error, truncate_up_ge], }
end

end rounding


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.pullbacks
import category_theory.limits.preserves.basic

/-!
# Preserving pullbacks

Constructions to relate the notions of preserving pullbacks and reflecting pullbacks to concrete
pullback cones.

In particular, we show that `pullback_comparison G f g` is an isomorphism iff `G` preserves
the pullback of `f` and `g`.

## TODO

* Dualise to pushouts
* Generalise to wide pullbacks

-/

noncomputable theory

universes v u₁ u₂

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v} C]
variables {D : Type u₂} [category.{v} D]
variables (G : C ⥤ D)

namespace category_theory.limits

variables {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {h : W ⟶ X} {k : W ⟶ Y} (comm : h ≫ f = k ≫ g)

/--
The map of a pullback cone is a limit iff the fork consisting of the mapped morphisms is a limit.
This essentially lets us commute `pullback_cone.mk` with `functor.map_cone`.
-/
def is_limit_map_cone_pullback_cone_equiv :
  is_limit (G.map_cone (pullback_cone.mk h k comm)) ≃
    is_limit (pullback_cone.mk (G.map h) (G.map k) (by simp only [← G.map_comp, comm])
      : pullback_cone (G.map f) (G.map g)) :=
(is_limit.postcompose_hom_equiv (diagram_iso_cospan _) _).symm.trans
  (is_limit.equiv_iso_limit (cones.ext (iso.refl _) (by { rintro (_ | _ | _), tidy })))

/-- The property of preserving pullbacks expressed in terms of binary fans. -/
def is_limit_pullback_cone_map_of_is_limit [preserves_limit (cospan f g) G]
  (l : is_limit (pullback_cone.mk h k comm)) :
  is_limit (pullback_cone.mk (G.map h) (G.map k) _) :=
is_limit_map_cone_pullback_cone_equiv G comm (preserves_limit.preserves l)

/-- The property of reflecting pullbacks expressed in terms of binary fans. -/
def is_limit_of_is_limit_pullback_cone_map [reflects_limit (cospan f g) G]
  (l : is_limit (pullback_cone.mk (G.map h) (G.map k) _)) :
  is_limit (pullback_cone.mk h k comm) :=
reflects_limit.reflects ((is_limit_map_cone_pullback_cone_equiv G comm).symm l)

variables (f g) [has_pullback f g]

/--
If `G` preserves pullbacks and `C` has them, then the pullback cone constructed of the mapped
morphisms of the pullback cone is a limit.
-/
def is_limit_of_has_pullback_of_preserves_limit
  [preserves_limit (cospan f g) G] :
  is_limit (pullback_cone.mk (G.map pullback.fst) (G.map pullback.snd) _) :=
is_limit_pullback_cone_map_of_is_limit G _ (pullback_is_pullback f g)

variables [has_pullback (G.map f) (G.map g)]

/--
If the pullback comparison map for `G` at `(f,g)` is an isomorphism, then `G` preserves the
pullback of `(f,g)`.
-/
def preserves_pullback.of_iso_comparison [i : is_iso (pullback_comparison G f g)] :
  preserves_limit (cospan f g) G :=
begin
  apply preserves_limit_of_preserves_limit_cone (pullback_is_pullback f g),
  apply (is_limit_map_cone_pullback_cone_equiv _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (cospan (G.map f) (G.map g))),
  apply i,
end

variables [preserves_limit (cospan f g) G]
/--
If `G` preserves the pullback of `(f,g)`, then the pullback comparison map for `G` at `(f,g)` is
an isomorphism.
-/
def preserves_pullback.iso :
  G.obj (pullback f g) ≅ pullback (G.map f) (G.map g) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_has_pullback_of_preserves_limit G f g)
  (limit.is_limit _)

@[simp]
lemma preserves_pullback.iso_hom :
  (preserves_pullback.iso G f g).hom = pullback_comparison G f g := rfl

instance : is_iso (pullback_comparison G f g) :=
begin
  rw ← preserves_pullback.iso_hom,
  apply_instance
end

end category_theory.limits


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.bump_function_findim
import geometry.manifold.cont_mdiff

/-!
# Smooth bump functions on a smooth manifold

In this file we define `smooth_bump_function I c` to be a bundled smooth "bump" function centered at
`c`. It is a structure that consists of two real numbers `0 < r < R` with small enough `R`. We
define a coercion to function for this type, and for `f : smooth_bump_function I c`, the function
`⇑f` written in the extended chart at `c` has the following properties:

* `f x = 1` in the closed ball of radius `f.r` centered at `c`;
* `f x = 0` outside of the ball of radius `f.R` centered at `c`;
* `0 ≤ f x ≤ 1` for all `x`.

The actual statements involve (pre)images under `ext_chart_at I f` and are given as lemmas in the
`smooth_bump_function` namespace.

## Tags

manifold, smooth bump function
-/

universes uE uF uH uM
variables
{E : Type uE} [normed_add_comm_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
{H : Type uH} [topological_space H] (I : model_with_corners ℝ E H)
{M : Type uM} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

open function filter finite_dimensional set metric
open_locale topology manifold classical filter big_operators

noncomputable theory

/-!
### Smooth bump function

In this section we define a structure for a bundled smooth bump function and prove its properties.
-/

/-- Given a smooth manifold modelled on a finite dimensional space `E`,
`f : smooth_bump_function I M` is a smooth function on `M` such that in the extended chart `e` at
`f.c`:

* `f x = 1` in the closed ball of radius `f.r` centered at `f.c`;
* `f x = 0` outside of the ball of radius `f.R` centered at `f.c`;
* `0 ≤ f x ≤ 1` for all `x`.

The structure contains data required to construct a function with these properties. The function is
available as `⇑f` or `f x`. Formal statements of the properties listed above involve some
(pre)images under `ext_chart_at I f.c` and are given as lemmas in the `smooth_bump_function`
namespace. -/
structure smooth_bump_function (c : M) extends cont_diff_bump (ext_chart_at I c c) :=
(closed_ball_subset : (closed_ball (ext_chart_at I c c) R) ∩ range I ⊆ (ext_chart_at I c).target)

variable {M}

namespace smooth_bump_function

variables {c : M} (f : smooth_bump_function I c) {x : M} {I}

/-- The function defined by `f : smooth_bump_function c`. Use automatic coercion to function
instead. -/
def to_fun : M → ℝ :=
indicator (chart_at H c).source (f.to_cont_diff_bump ∘ ext_chart_at I c)

instance : has_coe_to_fun (smooth_bump_function I c) (λ _, M → ℝ) := ⟨to_fun⟩

lemma coe_def :
  ⇑f = indicator (chart_at H c).source (f.to_cont_diff_bump ∘ ext_chart_at I c) :=
rfl

lemma R_pos : 0 < f.R := f.to_cont_diff_bump.R_pos

lemma ball_subset :
  ball (ext_chart_at I c c) f.R ∩ range I ⊆ (ext_chart_at I c).target :=
subset.trans (inter_subset_inter_left _ ball_subset_closed_ball) f.closed_ball_subset

lemma eq_on_source :
  eq_on f (f.to_cont_diff_bump ∘ ext_chart_at I c) (chart_at H c).source :=
eq_on_indicator

lemma eventually_eq_of_mem_source (hx : x ∈ (chart_at H c).source) :
  f =ᶠ[𝓝 x] f.to_cont_diff_bump ∘ ext_chart_at I c :=
f.eq_on_source.eventually_eq_of_mem $ is_open.mem_nhds (chart_at H c).open_source hx

lemma one_of_dist_le (hs : x ∈ (chart_at H c).source)
  (hd : dist (ext_chart_at I c x) (ext_chart_at I c c) ≤ f.r) :
  f x = 1 :=
by simp only [f.eq_on_source hs, (∘), f.to_cont_diff_bump.one_of_mem_closed_ball hd]

lemma support_eq_inter_preimage :
  support f =
    (chart_at H c).source ∩ (ext_chart_at I c ⁻¹' ball (ext_chart_at I c c) f.R) :=
by rw [coe_def, support_indicator, (∘), support_comp_eq_preimage, ← ext_chart_at_source I,
  ← (ext_chart_at I c).symm_image_target_inter_eq',
  ← (ext_chart_at I c).symm_image_target_inter_eq', f.to_cont_diff_bump.support_eq]

lemma is_open_support : is_open (support f) :=
by { rw support_eq_inter_preimage, exact is_open_ext_chart_at_preimage I c is_open_ball }

lemma support_eq_symm_image :
  support f = (ext_chart_at I c).symm '' (ball (ext_chart_at I c c) f.R ∩ range I) :=
begin
  rw [f.support_eq_inter_preimage, ← ext_chart_at_source I,
    ← (ext_chart_at I c).symm_image_target_inter_eq', inter_comm],
  congr' 1 with y,
  exact and.congr_right_iff.2
    (λ hy, ⟨λ h, ext_chart_at_target_subset_range _ _ h, λ h, f.ball_subset ⟨hy, h⟩⟩)
end

lemma support_subset_source : support f ⊆ (chart_at H c).source :=
by { rw [f.support_eq_inter_preimage, ← ext_chart_at_source I], exact inter_subset_left _ _ }

lemma image_eq_inter_preimage_of_subset_support {s : set M} (hs : s ⊆ support f) :
  ext_chart_at I c '' s =
    closed_ball (ext_chart_at I c c) f.R ∩ range I ∩ (ext_chart_at I c).symm ⁻¹' s :=
begin
  rw [support_eq_inter_preimage, subset_inter_iff, ← ext_chart_at_source I,
    ← image_subset_iff] at hs,
  cases hs with hse hsf,
  apply subset.antisymm,
  { refine subset_inter (subset_inter (subset.trans hsf ball_subset_closed_ball) _) _,
    { rintro _ ⟨x, -, rfl⟩, exact mem_range_self _ },
    { rw [(ext_chart_at I c).image_eq_target_inter_inv_preimage hse],
      exact inter_subset_right _ _ } },
  { refine subset.trans (inter_subset_inter_left _ f.closed_ball_subset) _,
    rw [(ext_chart_at I c).image_eq_target_inter_inv_preimage hse] }
end

lemma mem_Icc : f x ∈ Icc (0 : ℝ) 1 :=
begin
  have : f x = 0 ∨ f x = _, from indicator_eq_zero_or_self _ _ _,
  cases this; rw this,
  exacts [left_mem_Icc.2 zero_le_one,
    ⟨f.to_cont_diff_bump.nonneg, f.to_cont_diff_bump.le_one⟩]
end

lemma nonneg : 0 ≤ f x := f.mem_Icc.1

lemma le_one : f x ≤ 1 := f.mem_Icc.2

lemma eventually_eq_one_of_dist_lt (hs : x ∈ (chart_at H c).source)
  (hd : dist (ext_chart_at I c x) (ext_chart_at I c c) < f.r) :
  f =ᶠ[𝓝 x] 1 :=
begin
  filter_upwards [is_open.mem_nhds (is_open_ext_chart_at_preimage I c is_open_ball) ⟨hs, hd⟩],
  rintro z ⟨hzs, hzd : _ < _⟩,
  exact f.one_of_dist_le hzs hzd.le
end

lemma eventually_eq_one : f =ᶠ[𝓝 c] 1 :=
f.eventually_eq_one_of_dist_lt (mem_chart_source _ _) $
by { rw [dist_self], exact f.r_pos }

@[simp] lemma eq_one : f c = 1 := f.eventually_eq_one.eq_of_nhds

lemma support_mem_nhds : support f ∈ 𝓝 c :=
f.eventually_eq_one.mono $ λ x hx, by { rw hx, exact one_ne_zero }

lemma tsupport_mem_nhds : tsupport f ∈ 𝓝 c :=
mem_of_superset f.support_mem_nhds subset_closure

lemma c_mem_support : c ∈ support f := mem_of_mem_nhds f.support_mem_nhds

lemma nonempty_support : (support f).nonempty := ⟨c, f.c_mem_support⟩

lemma is_compact_symm_image_closed_ball :
  is_compact ((ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I)) :=
((is_compact_closed_ball _ _).inter_right I.closed_range).image_of_continuous_on $
  (continuous_on_ext_chart_at_symm _ _).mono f.closed_ball_subset

/-- Given a smooth bump function `f : smooth_bump_function I c`, the closed ball of radius `f.R` is
known to include the support of `f`. These closed balls (in the model normed space `E`) intersected
with `set.range I` form a basis of `𝓝[range I] (ext_chart_at I c c)`. -/
lemma nhds_within_range_basis :
  (𝓝[range I] (ext_chart_at I c c)).has_basis (λ f : smooth_bump_function I c, true)
    (λ f, closed_ball (ext_chart_at I c c) f.R ∩ range I) :=
begin
  refine ((nhds_within_has_basis nhds_basis_closed_ball _).restrict_subset
      (ext_chart_at_target_mem_nhds_within _ _)).to_has_basis' _ _,
  { rintro R ⟨hR0, hsub⟩,
    exact ⟨⟨⟨R / 2, R, half_pos hR0, half_lt_self hR0⟩, hsub⟩, trivial, subset.rfl⟩ },
  { exact λ f _, inter_mem (mem_nhds_within_of_mem_nhds $ closed_ball_mem_nhds _ f.R_pos)
      self_mem_nhds_within }
end

lemma is_closed_image_of_is_closed {s : set M} (hsc : is_closed s) (hs : s ⊆ support f) :
  is_closed (ext_chart_at I c '' s) :=
begin
  rw f.image_eq_inter_preimage_of_subset_support hs,
  refine continuous_on.preimage_closed_of_closed
    ((continuous_on_ext_chart_at_symm _ _).mono f.closed_ball_subset) _ hsc,
  exact is_closed.inter is_closed_ball I.closed_range
end

/-- If `f` is a smooth bump function and `s` closed subset of the support of `f` (i.e., of the open
ball of radius `f.R`), then there exists `0 < r < f.R` such that `s` is a subset of the open ball of
radius `r`. Formally, `s ⊆ e.source ∩ e ⁻¹' (ball (e c) r)`, where `e = ext_chart_at I c`. -/
lemma exists_r_pos_lt_subset_ball {s : set M} (hsc : is_closed s) (hs : s ⊆ support f) :
  ∃ r (hr : r ∈ Ioo 0 f.R), s ⊆
    (chart_at H c).source ∩ ext_chart_at I c ⁻¹' (ball (ext_chart_at I c c) r) :=
begin
  set e := ext_chart_at I c,
  have : is_closed (e '' s) := f.is_closed_image_of_is_closed hsc hs,
  rw [support_eq_inter_preimage, subset_inter_iff, ← image_subset_iff] at hs,
  rcases exists_pos_lt_subset_ball f.R_pos this hs.2 with ⟨r, hrR, hr⟩,
  exact ⟨r, hrR, subset_inter hs.1 (image_subset_iff.1 hr)⟩
end

/-- Replace `r` with another value in the interval `(0, f.R)`. -/
def update_r (r : ℝ) (hr : r ∈ Ioo 0 f.R) : smooth_bump_function I c :=
⟨⟨r, f.R, hr.1, hr.2⟩, f.closed_ball_subset⟩

@[simp] lemma update_r_R {r : ℝ} (hr : r ∈ Ioo 0 f.R) : (f.update_r r hr).R = f.R := rfl

@[simp] lemma update_r_r {r : ℝ} (hr : r ∈ Ioo 0 f.R) : (f.update_r r hr).r = r := rfl

@[simp] lemma support_update_r {r : ℝ} (hr : r ∈ Ioo 0 f.R) :
  support (f.update_r r hr) = support f :=
by simp only [support_eq_inter_preimage, update_r_R]

instance : inhabited (smooth_bump_function I c) :=
classical.inhabited_of_nonempty nhds_within_range_basis.nonempty

variables [t2_space M]

lemma is_closed_symm_image_closed_ball :
  is_closed ((ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I)) :=
f.is_compact_symm_image_closed_ball.is_closed

lemma tsupport_subset_symm_image_closed_ball :
  tsupport f ⊆ (ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I) :=
begin
  rw [tsupport, support_eq_symm_image],
  exact closure_minimal (image_subset _ $ inter_subset_inter_left _ ball_subset_closed_ball)
    f.is_closed_symm_image_closed_ball
end

lemma tsupport_subset_ext_chart_at_source :
  tsupport f ⊆ (ext_chart_at I c).source :=
calc tsupport f
    ⊆ (ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I) :
  f.tsupport_subset_symm_image_closed_ball
... ⊆ (ext_chart_at I c).symm '' (ext_chart_at I c).target :
  image_subset _ f.closed_ball_subset
... = (ext_chart_at I c).source :
  (ext_chart_at I c).symm_image_target_eq_source

lemma tsupport_subset_chart_at_source :
  tsupport f ⊆ (chart_at H c).source :=
by simpa only [ext_chart_at_source] using f.tsupport_subset_ext_chart_at_source

protected lemma has_compact_support : has_compact_support f :=
is_compact_of_is_closed_subset f.is_compact_symm_image_closed_ball is_closed_closure
 f.tsupport_subset_symm_image_closed_ball

variables (I c)

/-- The closures of supports of smooth bump functions centered at `c` form a basis of `𝓝 c`.
In other words, each of these closures is a neighborhood of `c` and each neighborhood of `c`
includes `tsupport f` for some `f : smooth_bump_function I c`. -/
lemma nhds_basis_tsupport :
  (𝓝 c).has_basis (λ f : smooth_bump_function I c, true) (λ f, tsupport f) :=
begin
  have : (𝓝 c).has_basis (λ f : smooth_bump_function I c, true)
    (λ f, (ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I)),
  { rw [← map_ext_chart_at_symm_nhds_within_range I c],
    exact nhds_within_range_basis.map _ },
  refine this.to_has_basis' (λ f hf, ⟨f, trivial, f.tsupport_subset_symm_image_closed_ball⟩)
    (λ f _, f.tsupport_mem_nhds),
end

variable {c}

/-- Given `s ∈ 𝓝 c`, the supports of smooth bump functions `f : smooth_bump_function I c` such that
`tsupport f ⊆ s` form a basis of `𝓝 c`.  In other words, each of these supports is a
neighborhood of `c` and each neighborhood of `c` includes `support f` for some `f :
smooth_bump_function I c` such that `tsupport f ⊆ s`. -/
lemma nhds_basis_support {s : set M} (hs : s ∈ 𝓝 c) :
  (𝓝 c).has_basis (λ f : smooth_bump_function I c, tsupport f ⊆ s) (λ f, support f) :=
((nhds_basis_tsupport I c).restrict_subset hs).to_has_basis'
  (λ f hf, ⟨f, hf.2, subset_closure⟩) (λ f hf, f.support_mem_nhds)

variables [smooth_manifold_with_corners I M] {I}

/-- A smooth bump function is infinitely smooth. -/
protected lemma smooth : smooth I 𝓘(ℝ) f :=
begin
  refine cont_mdiff_of_support (λ x hx, _),
  have : x ∈ (chart_at H c).source := f.tsupport_subset_chart_at_source hx,
  refine cont_mdiff_at.congr_of_eventually_eq _
    (f.eq_on_source.eventually_eq_of_mem $ is_open.mem_nhds (chart_at _ _).open_source this),
  exact f.to_cont_diff_bump.cont_diff_at.cont_mdiff_at.comp _
    (cont_mdiff_at_ext_chart_at' this)
end

protected lemma smooth_at {x} : smooth_at I 𝓘(ℝ) f x := f.smooth.smooth_at

protected lemma continuous : continuous f := f.smooth.continuous

/-- If `f : smooth_bump_function I c` is a smooth bump function and `g : M → G` is a function smooth
on the source of the chart at `c`, then `f • g` is smooth on the whole manifold. -/
lemma smooth_smul {G} [normed_add_comm_group G] [normed_space ℝ G]
  {g : M → G} (hg : smooth_on I 𝓘(ℝ, G) g (chart_at H c).source) :
  smooth I 𝓘(ℝ, G) (λ x, f x • g x) :=
begin
  apply cont_mdiff_of_support (λ x hx, _),
  have : x ∈ (chart_at H c).source,
  calc x ∈ tsupport (λ x, f x • g x) : hx
     ... ⊆ tsupport f : tsupport_smul_subset_left _ _
     ... ⊆ (chart_at _ c).source : f.tsupport_subset_chart_at_source,
  exact f.smooth_at.smul ((hg _ this).cont_mdiff_at $
    is_open.mem_nhds (chart_at _ _).open_source this)
end

end smooth_bump_function


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

! This file was ported from Lean 3 source module algebra.homology.homotopy_category
! leanprover-community/mathlib commit 13ff898b0eee75d3cc75d1c06a491720eaaf911d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Homology.Homotopy
import Mathbin.CategoryTheory.Quotient

/-!
# The homotopy category

`homotopy_category V c` gives the category of chain complexes of shape `c` in `V`,
with chain maps identified when they are homotopic.
-/

universe v u

open Classical

noncomputable section

open CategoryTheory CategoryTheory.Limits HomologicalComplex

variable {ι : Type _}

variable (V : Type u) [Category.{v} V] [Preadditive V]

variable (c : ComplexShape ι)

/-- The congruence on `homological_complex V c` given by the existence of a homotopy.
-/
def homotopic : HomRel (HomologicalComplex V c) := fun C D f g => Nonempty (Homotopy f g)
#align homotopic homotopic

instance homotopy_congruence : Congruence (homotopic V c)
    where
  IsEquiv C D :=
    { refl := fun C => ⟨Homotopy.refl C⟩
      symm := fun f g ⟨w⟩ => ⟨w.symm⟩
      trans := fun f g h ⟨w₁⟩ ⟨w₂⟩ => ⟨w₁.trans w₂⟩ }
  compLeft := fun E F G m₁ m₂ g ⟨i⟩ => ⟨i.compLeft _⟩
  compRight := fun E F G f m₁ m₂ ⟨i⟩ => ⟨i.compRight _⟩
#align homotopy_congruence homotopy_congruence

/-- `homotopy_category V c` is the category of chain complexes of shape `c` in `V`,
with chain maps identified when they are homotopic. -/
def HomotopyCategory :=
  CategoryTheory.Quotient (homotopic V c)deriving Category
#align homotopy_category HomotopyCategory

-- TODO the homotopy_category is preadditive
namespace HomotopyCategory

/-- The quotient functor from complexes to the homotopy category. -/
def quotient : HomologicalComplex V c ⥤ HomotopyCategory V c :=
  CategoryTheory.Quotient.functor _
#align homotopy_category.quotient HomotopyCategory.quotient

open ZeroObject

-- TODO upgrade this to `has_zero_object`, presumably for any `quotient`.
instance [HasZeroObject V] : Inhabited (HomotopyCategory V c) :=
  ⟨(quotient V c).obj 0⟩

variable {V c}

@[simp]
theorem quotient_obj_as (C : HomologicalComplex V c) : ((quotient V c).obj C).as = C :=
  rfl
#align homotopy_category.quotient_obj_as HomotopyCategory.quotient_obj_as

@[simp]
theorem quotient_map_out {C D : HomotopyCategory V c} (f : C ⟶ D) : (quotient V c).map f.out = f :=
  Quot.out_eq _
#align homotopy_category.quotient_map_out HomotopyCategory.quotient_map_out

theorem eq_of_homotopy {C D : HomologicalComplex V c} (f g : C ⟶ D) (h : Homotopy f g) :
    (quotient V c).map f = (quotient V c).map g :=
  CategoryTheory.Quotient.sound _ ⟨h⟩
#align homotopy_category.eq_of_homotopy HomotopyCategory.eq_of_homotopy

/-- If two chain maps become equal in the homotopy category, then they are homotopic. -/
def homotopyOfEq {C D : HomologicalComplex V c} (f g : C ⟶ D)
    (w : (quotient V c).map f = (quotient V c).map g) : Homotopy f g :=
  ((Quotient.functor_map_eq_iff _ _ _).mp w).some
#align homotopy_category.homotopy_of_eq HomotopyCategory.homotopyOfEq

/-- An arbitrarily chosen representation of the image of a chain map in the homotopy category
is homotopic to the original chain map.
-/
def homotopyOutMap {C D : HomologicalComplex V c} (f : C ⟶ D) :
    Homotopy ((quotient V c).map f).out f :=
  by
  apply homotopy_of_eq
  simp
#align homotopy_category.homotopy_out_map HomotopyCategory.homotopyOutMap

@[simp]
theorem quotient_map_out_comp_out {C D E : HomotopyCategory V c} (f : C ⟶ D) (g : D ⟶ E) :
    (quotient V c).map (Quot.out f ≫ Quot.out g) = f ≫ g := by
  conv_rhs => erw [← quotient_map_out f, ← quotient_map_out g, ← (Quotient V c).map_comp]
#align homotopy_category.quotient_map_out_comp_out HomotopyCategory.quotient_map_out_comp_out

/-- Homotopy equivalent complexes become isomorphic in the homotopy category. -/
@[simps]
def isoOfHomotopyEquiv {C D : HomologicalComplex V c} (f : HomotopyEquiv C D) :
    (quotient V c).obj C ≅ (quotient V c).obj D
    where
  Hom := (quotient V c).map f.Hom
  inv := (quotient V c).map f.inv
  hom_inv_id' := by
    rw [← (Quotient V c).map_comp, ← (Quotient V c).map_id]
    exact eq_of_homotopy _ _ f.homotopy_hom_inv_id
  inv_hom_id' := by
    rw [← (Quotient V c).map_comp, ← (Quotient V c).map_id]
    exact eq_of_homotopy _ _ f.homotopy_inv_hom_id
#align homotopy_category.iso_of_homotopy_equiv HomotopyCategory.isoOfHomotopyEquiv

/-- If two complexes become isomorphic in the homotopy category,
  then they were homotopy equivalent. -/
def homotopyEquivOfIso {C D : HomologicalComplex V c}
    (i : (quotient V c).obj C ≅ (quotient V c).obj D) : HomotopyEquiv C D
    where
  Hom := Quot.out i.Hom
  inv := Quot.out i.inv
  homotopyHomInvId :=
    homotopyOfEq _ _
      (by
        simp
        rfl)
  homotopyInvHomId :=
    homotopyOfEq _ _
      (by
        simp
        rfl)
#align homotopy_category.homotopy_equiv_of_iso HomotopyCategory.homotopyEquivOfIso

variable (V c) [HasEqualizers V] [HasImages V] [HasImageMaps V] [HasCokernels V]

/-- The `i`-th homology, as a functor from the homotopy category. -/
def homologyFunctor (i : ι) : HomotopyCategory V c ⥤ V :=
  CategoryTheory.Quotient.lift _ (homologyFunctor V c i) fun C D f g ⟨h⟩ =>
    homology_map_eq_of_homotopy h i
#align homotopy_category.homology_functor HomotopyCategory.homologyFunctor

/-- The homology functor on the homotopy category is just the usual homology functor. -/
def homologyFactors (i : ι) : quotient V c ⋙ homologyFunctor V c i ≅ homologyFunctor V c i :=
  CategoryTheory.Quotient.lift.isLift _ _ _
#align homotopy_category.homology_factors HomotopyCategory.homologyFactors

@[simp]
theorem homologyFactors_hom_app (i : ι) (C : HomologicalComplex V c) :
    (homologyFactors V c i).Hom.app C = 𝟙 _ :=
  rfl
#align homotopy_category.homology_factors_hom_app HomotopyCategory.homologyFactors_hom_app

@[simp]
theorem homologyFactors_inv_app (i : ι) (C : HomologicalComplex V c) :
    (homologyFactors V c i).inv.app C = 𝟙 _ :=
  rfl
#align homotopy_category.homology_factors_inv_app HomotopyCategory.homologyFactors_inv_app

theorem homologyFunctor_map_factors (i : ι) {C D : HomologicalComplex V c} (f : C ⟶ D) :
    (homologyFunctor V c i).map f = ((homologyFunctor V c i).map ((quotient V c).map f) : _) :=
  (CategoryTheory.Quotient.lift_map_functor_map _ (homologyFunctor V c i) _ f).symm
#align homotopy_category.homology_functor_map_factors HomotopyCategory.homologyFunctor_map_factors

end HomotopyCategory

namespace CategoryTheory

variable {V} {W : Type _} [Category W] [Preadditive W]

/-- An additive functor induces a functor between homotopy categories. -/
@[simps]
def Functor.mapHomotopyCategory (c : ComplexShape ι) (F : V ⥤ W) [F.Additive] :
    HomotopyCategory V c ⥤ HomotopyCategory W c
    where
  obj C := (HomotopyCategory.quotient W c).obj ((F.mapHomologicalComplex c).obj C.as)
  map C D f := (HomotopyCategory.quotient W c).map ((F.mapHomologicalComplex c).map (Quot.out f))
  map_id' C := by
    rw [← (HomotopyCategory.quotient W c).map_id]
    apply HomotopyCategory.eq_of_homotopy
    rw [← (F.map_homological_complex c).map_id]
    apply F.map_homotopy
    apply HomotopyCategory.homotopyOfEq
    exact Quot.out_eq _
  map_comp' C D E f g := by
    rw [← (HomotopyCategory.quotient W c).map_comp]
    apply HomotopyCategory.eq_of_homotopy
    rw [← (F.map_homological_complex c).map_comp]
    apply F.map_homotopy
    apply HomotopyCategory.homotopyOfEq
    convert Quot.out_eq _
    exact HomotopyCategory.quotient_map_out_comp_out _ _
#align category_theory.functor.map_homotopy_category CategoryTheory.Functor.mapHomotopyCategory

-- TODO `F.map_homotopy_category c` is additive (and linear when `F` is linear).
/-- A natural transformation induces a natural transformation between
  the induced functors on the homotopy category. -/
@[simps]
def NatTrans.mapHomotopyCategory {F G : V ⥤ W} [F.Additive] [G.Additive] (α : F ⟶ G)
    (c : ComplexShape ι) : F.mapHomotopyCategory c ⟶ G.mapHomotopyCategory c
    where
  app C := (HomotopyCategory.quotient W c).map ((NatTrans.mapHomologicalComplex α c).app C.as)
  naturality' C D f := by
    dsimp
    simp only [← functor.map_comp]
    congr 1
    ext
    dsimp
    simp
#align category_theory.nat_trans.map_homotopy_category CategoryTheory.NatTrans.mapHomotopyCategory

@[simp]
theorem NatTrans.mapHomotopyCategory_id (c : ComplexShape ι) (F : V ⥤ W) [F.Additive] :
    NatTrans.mapHomotopyCategory (𝟙 F) c = 𝟙 (F.mapHomotopyCategory c) := by tidy
#align category_theory.nat_trans.map_homotopy_category_id CategoryTheory.NatTrans.mapHomotopyCategory_id

@[simp]
theorem NatTrans.mapHomotopyCategory_comp (c : ComplexShape ι) {F G H : V ⥤ W} [F.Additive]
    [G.Additive] [H.Additive] (α : F ⟶ G) (β : G ⟶ H) :
    NatTrans.mapHomotopyCategory (α ≫ β) c =
      NatTrans.mapHomotopyCategory α c ≫ NatTrans.mapHomotopyCategory β c :=
  by tidy
#align category_theory.nat_trans.map_homotopy_category_comp CategoryTheory.NatTrans.mapHomotopyCategory_comp

end CategoryTheory


definition cong_mod_n (n a b : ℤ) := ∃ k : ℤ, n * k = a - b

theorem cong_mod_n_equiv : ∀ (n : ℕ), equivalence (cong_mod_n n) := λ n,
⟨λ a, ⟨0, by rw [mul_zero, sub_eq_add_neg, add_neg_self]⟩, λ x y h, exists.elim h
(λ a cong, ⟨-a, by rw [←neg_mul_eq_mul_neg, cong, neg_sub]⟩), λ x y z hxy hyz, exists.elim hxy
(λ k congxy, exists.elim hyz (λ t congyz, ⟨k+t, by rw [mul_add, congxy, congyz,
sub_eq_add_neg y z, ←add_assoc, sub_add_cancel, sub_eq_add_neg]⟩))⟩


import algebra.module.linear_map
-- import algebra.module.graded_module
import ring_theory.graded_algebra.homogeneous_ideal
import ring_theory.ideal.quotient
import ring_theory.ideal.quotient_operations

section classes

section linear_map

variables {R : Type*} [semiring R]
variables {β γ : Type*}
  [add_comm_monoid β] [module R β]
  [add_comm_monoid γ] [module R γ]

instance {F : Type*} [linear_map_class F R β γ] : has_coe_t F (β →ₗ[R] γ) :=
{ coe := λ h, ⟨h, map_add h, map_smulₛₗ h⟩ }

lemma linear_map.coe_coe {F : Type*} [linear_map_class F R β γ] (f : F) :
 ((f : β →ₗ[R] γ) : β → γ) = f := rfl

lemma linear_map.coe_coe' {F : Type*} [linear_map_class F R β γ] (f : F) :
 ((f : β →ₗ[R] γ) : β →+ γ) = f := rfl

example {F : Type*} [linear_map_class F R β γ] (h : F) (b : β): (h : β →ₗ[R] γ) b = h b := rfl

end linear_map

section alg_hom

variables {R : Type*} [comm_semiring R]
variables {β γ : Type*}
  [semiring β] [algebra R β]
  [semiring γ] [algebra R γ]

lemma alg_hom.to_linear_map_coe_coe {F : Type*} [alg_hom_class F R β γ] (h : F) : ((h : β →ₗ[R] γ) : β → γ) = h := rfl

end alg_hom

section Nat_module

example {β : Type*} [add_comm_monoid β] : module ℕ β := add_comm_monoid.nat_module

example {β γ : Type*} [add_comm_monoid β] [add_comm_monoid γ] (f : β →+ γ) : β →ₗ[ℕ] γ :=
{ to_fun := f,
  map_add' := f.map_add,
  map_smul' := λ r x, by simp only [map_nsmul, eq_nat_cast, nat.cast_id] }

example {β γ : Type*} [add_comm_monoid β] [add_comm_monoid γ] (f : β →+ γ) : β →ₗ[ℕ] γ :=
f.to_nat_linear_map

example {β γ : Type*} [add_comm_monoid β] [add_comm_monoid γ] (f : β →ₗ[ℕ] γ) : β →+ γ :=
f.to_add_monoid_hom

example {β γ : Type*} [add_comm_monoid β] [add_comm_monoid γ] (f : β →ₗ[ℕ] γ) :
 f =  f.to_add_monoid_hom.to_nat_linear_map  :=
linear_map.ext (λ _, eq.refl _)

example {β γ : Type*} [add_comm_monoid β] [add_comm_monoid γ] (f : β →+ γ) :
  f = f.to_nat_linear_map.to_add_monoid_hom :=
add_monoid_hom.ext (λ _, eq.refl _)

end Nat_module

section Int_module

example {β : Type*} [add_comm_group β]: module ℤ β := add_comm_group.int_module β

example {β γ : Type*} [add_comm_group β] [add_comm_group γ] (f : β →+ γ) : β →ₗ[ℤ] γ :=
{ to_fun := f,
  map_add' := f.map_add,
  map_smul' := λ r x, by simp only [eq_int_cast, int.cast_id, map_zsmul f r x] }

example {β γ : Type*} [add_comm_group β] [add_comm_group γ] (f : β →+ γ) : β →ₗ[ℤ] γ :=
f.to_int_linear_map

end Int_module

section direct_sum

variables {ι : Type*} [decidable_eq ι]

variables {R : Type*} [semiring R]

/-- The components of a direct sum, as add_monoid_hom -/
def direct_sum.component' {β : ι → Type* }
  [Π i, add_comm_monoid (β i)] (i : ι) : direct_sum ι β →+ β i :=
direct_sum.component ℕ ι β i

lemma direct_sum.component'_eq {β : ι → Type* }
  [Π i, add_comm_monoid (β i)] (x : direct_sum ι β) (i : ι):
  direct_sum.component' i x = x i := rfl

lemma direct_sum.eq_iff_component'_eq {β : ι → Type* }
  [Π i, add_comm_monoid (β i)] (x y : direct_sum ι β) :
  x = y ↔  ∀ i, direct_sum.component' i x = direct_sum.component' i y :=
direct_sum.ext_iff ℕ

-- add_monoid_hom from a direct_sum to an add_comm_monoid
example {β : ι → Type*} [Π  i, add_comm_monoid (β i)] {γ : Type*} [add_comm_monoid γ]
  (h : Π i, β i →+ γ) : direct_sum ι β →+ γ :=
direct_sum.to_add_monoid h

-- linear_map from a direct_sum to a module
example {β : ι → Type*}
  [Π  i, add_comm_monoid (β i)] [Π i, module R (β i)]
  {γ : Type*} [add_comm_monoid γ] [module R γ]
  (h : Π i, β i →ₗ[R] γ) : direct_sum ι β →ₗ[R] γ :=
direct_sum.to_module R ι γ h

-- linear_map, with classes :
example {β : ι → Type*}
  [Π  i, add_comm_monoid (β i)] [Π i, module R (β i)]
  {γ : Type*} [add_comm_monoid γ] [module R γ]
  {F : Π (i : ι), Type*} [Π i, linear_map_class (F i) R (β i) γ]
  (h : Π i, F i) : direct_sum ι β →ₗ[R] γ :=
direct_sum.to_module R ι γ (λ i, h i)
-- ⟨h i, map_add _, map_smulₛₗ _⟩

example {β : ι → Type*}
  [Π  i, add_comm_monoid (β i)] [Π i, module R (β i)]
  {γ : Type*} [add_comm_monoid γ] [module R γ]
  {F : Π (i : ι), Type*} [Π i, linear_map_class (F i) R (β i) γ]
  (h : Π i, F i) : direct_sum ι β →ₗ[R] γ :=
direct_sum.to_module R ι γ (λ i, h i)

/- Four versions of a direct sum of maps
   direct_sum.map' : for add_monoid_hom
   direct_sum.lmap'  : for linear_map
   the unprimed versions are defined in terms of classes
   In principle, the latter should suffice. -/

/-- Linear_maps from a direct sum to a direct sum given by families of linear_maps-/

def direct_sum.map {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  {F : Π (i : ι), Type*} [Π i, add_monoid_hom_class (F i) (β i) (γ i)]
  (h : Π i, F i) :
  direct_sum ι β →+ direct_sum ι γ :=
direct_sum.to_add_monoid (λ i, add_monoid_hom.comp (direct_sum.of γ i) (h i))

def direct_sum.lmap {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, module R (β i)]
  [Π i, add_comm_monoid (γ i)] [Π i, module R (γ i)]
  {F : Π (i : ι), Type*} [Π i, linear_map_class (F i) R (β i) (γ i)]
  (h : Π i, F i) :
  direct_sum ι β →ₗ[R] direct_sum ι γ :=
direct_sum.to_module R ι (direct_sum ι γ)
  (λ i, linear_map.comp (direct_sum.lof R ι γ i) (h i : β i →ₗ[R] γ i))

def direct_sum.map' {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  (h : Π i, β i →+ γ i) : direct_sum ι β →+ direct_sum ι γ :=
direct_sum.to_add_monoid (λ i, add_monoid_hom.comp (direct_sum.of γ i) (h i))

example {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  (h : Π i, β i →+ γ i) : direct_sum.map' h = direct_sum.map h :=  rfl

def direct_sum.lmap' {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, module R (β i)]
  [Π i, add_comm_monoid (γ i)] [Π i, module R (γ i)]
  (h : Π i, β i →ₗ[R] γ i) :
  direct_sum ι β →ₗ[R] direct_sum ι γ :=
direct_sum.to_module R ι _ (λ i, linear_map.comp (direct_sum.lof R ι γ i) (h i))

example {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] -- [Π i, module R (β i)]
  [Π i, add_comm_monoid (γ i)] -- [Π i, module R (γ i)]
  (h : Π i, β i →+ γ i) : direct_sum ι β →+ direct_sum ι γ :=
direct_sum.map' h

example {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] -- [Π i, module ℕ (β i)]
  [Π i, add_comm_monoid (γ i)] -- [Π i, module ℕ (γ i)]
  (h : Π i, (β i) →+ (γ i)) : direct_sum ι β →+ direct_sum ι γ :=
direct_sum.lmap' (λ i, ((h i).to_nat_linear_map : (β i) →ₗ[ℕ] (γ i)))

lemma direct_sum.map'_eq_lmap'_to_add_monoid_hom {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] -- [Π i, module R (β i)]
  [Π i, add_comm_monoid (γ i)] -- [Π i, module R (γ i)]
  (h : Π i, β i →+ γ i) : direct_sum.map' h
= (direct_sum.lmap' (λ i, (h i).to_nat_linear_map)).to_add_monoid_hom := rfl

lemma direct_sum.lmap'_to_add_monoid_hom_eq_map' {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, module R (β i)]
  [Π i, add_comm_monoid (γ i)] [Π i, module R (γ i)]
  (h : Π i, β i →ₗ[R] γ i) :
(direct_sum.lmap' h).to_add_monoid_hom = direct_sum.map' (λ i, (h i).to_add_monoid_hom) := rfl

example {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, module R (β i)]
  [Π i, add_comm_monoid (γ i)] [Π i, module R (γ i)]
  (h : Π i, β i →ₗ[R] γ i) :
(direct_sum.lmap' h) = direct_sum.lmap (h) :=
begin
  refl,
end

/- Lemmas to help computation -/

lemma direct_sum.map_of {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  {F : Π i, Type*} [Π i, add_monoid_hom_class (F i) (β i) (γ i)]
  (h : Π i, F i) (i : ι) (x : β i) :
  direct_sum.map h (direct_sum.of β i x) = direct_sum.of γ i (h i x) :=
by simp only [direct_sum.map, direct_sum.to_add_monoid_of, add_monoid_hom.coe_comp, add_monoid_hom.coe_coe]

/- unknown constant…
lemma direct_sum.map_apply {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  {F : Π i, Type*} [Π i, add_monoid_hom_class (F i) (β i) (γ i)]
  (h : Π i, F i) (x : direct_sum ι β) (i : ι) :
  direct_sum.map h x i = h i (x i) :=
begin
  let f : direct_sum ι β →+ γ i :=
  { to_fun := λ x, direct_sum.map' h x i,
    map_zero' := by simp,
    map_add' := by simp, },
  let g : direct_sum ι β →+ γ i :=
  { to_fun := λ y, h i (y i),
    map_zero' := by simp,
    map_add' := by simp, } ,
  change f x = g x,
  suffices : f = g,
  rw this,
  apply direct_sum.add_hom_ext ,
  intros j y,
  simp [f, g, direct_sum.map'_of],
  by_cases hj : j = i,
  { rw ← hj, simp only [direct_sum.of_eq_same], },
  { simp only [direct_sum.of_eq_of_ne _ j i _ hj, map_zero], },
end
-/

lemma direct_sum.map'_of {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  (h : Π i, β i →+ γ i) (i : ι) (x : β i) :
  direct_sum.map' h (direct_sum.of β i x) = direct_sum.of γ i (h i x) :=
begin
  dsimp only [direct_sum.map'],
  rw direct_sum.to_add_monoid_of ,
  simp only [add_monoid_hom.coe_comp],
end

lemma direct_sum.lmap'_lof {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  [Π i, module R (β i)] [Π i, module R (γ i)]
  (h : Π i, β i →ₗ[R] γ i) (i : ι) (x : β i) :
  direct_sum.lmap' h (direct_sum.lof R ι β i x) = direct_sum.lof R ι γ i (h i x) :=
begin
  dsimp only [direct_sum.lmap'],
  rw direct_sum.to_module_lof,
  simp only [linear_map.coe_comp],
end

lemma direct_sum.lmap'_apply {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  [Π i, module R (β i)] [Π i, module R (γ i)]
  (h : Π i, β i →ₗ[R] γ i) (x : direct_sum ι β) (i : ι) :
  direct_sum.lmap' h x i = h i (x i) :=
begin
  simp only [direct_sum.apply_eq_component R],
  rw ← linear_map.comp_apply,
  rw ← linear_map.comp_apply,
  revert x, rw ← linear_map.ext_iff,
  apply direct_sum.linear_map_ext ,
  intro j, ext y,
  simp only [linear_map.comp_apply],
  rw [direct_sum.lmap'_lof ],
  simp only [direct_sum.lof_eq_of],
  simp only [←direct_sum.apply_eq_component],
  by_cases hji : j = i,
  { rw ← hji, simp only [direct_sum.of_eq_same], },
  { simp only [direct_sum.of_eq_of_ne _ j i _ hji, map_zero], },
end

lemma direct_sum.to_module_comp_lmap'_eq
  {β γ: ι → Type*} {δ : Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)] [add_comm_monoid δ]
  [Π i, module R (β i)] [Π i, module R (γ i)] [module R δ]
  (h : Π i, β i →ₗ[R] γ i)
  (f : Π i, γ i →ₗ[R] δ)
  (x : direct_sum ι β) :
  direct_sum.to_module R ι δ f (direct_sum.lmap' h x) =
  direct_sum.to_module R ι δ (λ i, (f i).comp (h i)) x :=
begin
  rw ← linear_map.comp_apply,
  revert x,
  rw ← linear_map.ext_iff,
  apply direct_sum.linear_map_ext ,
  intro i,
  apply linear_map.ext,
  intro b,
  simp,
  rw direct_sum.lmap'_lof,
  rw direct_sum.to_module_lof,
end

lemma direct_sum.map'_apply {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  [Π (i : ι) (x : β i), decidable (x ≠ 0)]
  [Π (i : ι) (x : γ i), decidable (x ≠ 0)]
  (h : Π i, β i →+ γ i) (x : direct_sum ι β) (i : ι) :
  direct_sum.map' h x i = h i (x i) :=
begin
  let f : direct_sum ι β →+ γ i :=
  { to_fun := λ x, direct_sum.map' h x i,
    map_zero' := by simp only [map_zero, direct_sum.zero_apply],
    map_add' := by simp only [map_add, direct_sum.add_apply, eq_self_iff_true, forall_const], },
  let g : direct_sum ι β →+ γ i :=
  { to_fun := λ y, h i (y i),
    map_zero' := by simp only [direct_sum.zero_apply, map_zero],
    map_add' := by simp only [direct_sum.add_apply, map_add, eq_self_iff_true, forall_const], } ,
  change f x = g x,
  suffices : f = g,
  rw this,
  apply direct_sum.add_hom_ext ,
  intros j y,
  simp [f, g, direct_sum.map'_of],
  by_cases hj : j = i,
  { rw ← hj, simp only [direct_sum.of_eq_same], },
  { simp only [direct_sum.of_eq_of_ne _ j i _ hj, map_zero], },
end

/- Lemmas using direct_sum.mk   : could probably be removed -/
lemma direct_sum.mk_apply {β : ι → Type*} [Π i, add_comm_monoid (β i)] (s : finset ι)
  (f : Π (i : s), β ↑i) (i : ι) : direct_sum.mk β s f i = dite (i ∈ s) (λ h, f ⟨i, h⟩) (λ h, 0) :=
rfl

lemma direct_sum.mk_eq_sum' {β : ι → Type*} [Π i, add_comm_monoid (β i)]
  [Π (i : ι) (x : β i), decidable (x ≠ 0)] (s : finset ι) (f : Π i, β i) :
  direct_sum.mk β s (λ (i : ↥↑s), f i) = s.sum (λ i, direct_sum.of β i (f i)) :=
begin
  ext i,
  rw [direct_sum.mk_apply, dfinsupp.finset_sum_apply],
  split_ifs with hi hi,
  { rw finset.sum_eq_single_of_mem i hi,
    { rw [← direct_sum.lof_eq_of ℕ, direct_sum.lof_apply],
      refl },
    { intros j hj hij,
      exact direct_sum.of_eq_of_ne _ _ _ _ hij }},
  { apply symm,
    apply finset.sum_eq_zero,
    intros j hj,
    exact direct_sum.of_eq_of_ne _ _ _ _ (ne_of_mem_of_not_mem hj hi) },
end

lemma dfinsupp.mk_eq_sum {β : ι → Type*} [Π i, add_comm_monoid (β i)]
  [Π (i : ι) (x : β i), decidable (x ≠ 0)] (s : finset ι) (f : Π i, β i) :
  dfinsupp.mk s (λ (i : ↥↑s), f i) = s.sum (λ i, direct_sum.of β i (f i)) :=
begin
  ext i,
  simp only [dfinsupp.mk_apply, dfinsupp.finset_sum_apply],
  split_ifs with hi hi,
  { rw finset.sum_eq_single_of_mem i hi,
    rw direct_sum.of_eq_same, refl,
    intros j hj hij,
    rw direct_sum.of_eq_of_ne,
    exact hij, },
  { apply symm, apply finset.sum_eq_zero,
    intros j hj,
    rw direct_sum.of_eq_of_ne,
    intro hij, apply hi, rw ← hij, exact hj, },
end

lemma direct_sum.mk_eq_sum {β : ι → Type*} [Π  i, add_comm_monoid (β i)]
  [Π (i : ι) (x : β i), decidable (x ≠ 0)] (s : finset ι) (x : Π (i : s), β i) :
  direct_sum.mk β s x
    = s.sum (λ i, direct_sum.of β i (dite (i ∈ s) (λ hi, x ⟨i, hi⟩) (λ hi, 0) )) :=
begin
  ext i,
  rw [dfinsupp.finset_sum_apply, direct_sum.mk_apply],
  split_ifs with hi hi,
  { rw finset.sum_eq_single i,
    { rw [direct_sum.of_eq_same, dif_pos hi] },
    { intros j hjs hji,
      exact direct_sum.of_eq_of_ne _ _ _ _ hji},
    { intro his,
      rw [direct_sum.of_eq_same, dif_neg his] }},
  { apply symm, apply finset.sum_eq_zero,
    intros j hj,
    rw direct_sum.of_eq_of_ne  _ _ _ _ (ne_of_mem_of_not_mem hj hi) },
end

lemma direct_sum.to_add_monoid_mk {β : ι → Type*} [Π  i, add_comm_monoid (β i)] {γ : Type*}
  [add_comm_monoid γ] [Π (i : ι) (x : β i), decidable (x ≠ 0)] [Π (x : γ), decidable (x ≠ 0)]
  (ψ : Π i, (β i →+ γ)) (s : finset ι) (x : Π (i : s), β i) :
  direct_sum.to_add_monoid ψ (direct_sum.mk β s x)
    = s.sum (λ i, ψ i (dite (i ∈ s) (λ hi, x ⟨i, hi⟩) (λ hi, 0))) :=
begin
  rw [direct_sum.mk_eq_sum, map_sum],
  apply finset.sum_congr rfl,
  intros i hi,
  rw direct_sum.to_add_monoid_of,
end

lemma direct_sum.map'_apply'_old {β γ : ι → Type*} [Π i, add_comm_monoid (β i)]
  [Π i, add_comm_monoid (γ i)] [Π (i : ι) (x : β i), decidable (x ≠ 0)]
  [Π (i : ι) (x : γ i), decidable (x ≠ 0)] (h : Π i, β i →+ γ i) (x : direct_sum ι β) :
  direct_sum.map' h x = direct_sum.mk γ (x.support) (λ i, h i (x i)) :=
begin
  conv_lhs {rw ← direct_sum.sum_support_of β x, },
  rw map_sum,
  simp_rw direct_sum.map'_of,
  apply symm,
  convert direct_sum.mk_eq_sum (x.support) (λ i, (h i) (x i)),
  apply funext,
  intro i,
  dsimp,
  apply congr_arg,
  split_ifs with hi,
  refl,
  rw dfinsupp.not_mem_support_iff at hi,
  rw hi, simp only [map_zero],

end

def zoto
{β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  [Π (i : ι) (x : β i), decidable (x ≠ 0)]
  [Π (i : ι) (x : γ i), decidable (x ≠ 0)]
  {F : Π i, Type*} [Π i, add_monoid_hom_class (F i) (β i) (γ i)]
  (h : Π i, F i)
  (B : direct_sum ι β) : Π i : (B.support : set ι), (γ i) := λ i, (h i) (B i)

lemma direct_sum.map_apply' {β γ : ι → Type*}
  [Π i, add_comm_monoid (β i)] [Π i, add_comm_monoid (γ i)]
  [Π (i : ι) (x : β i), decidable (x ≠ 0)]
  [Π (i : ι) (x : γ i), decidable (x ≠ 0)]
  {F : Π i, Type*} [Π i, add_monoid_hom_class (F i) (β i) (γ i)]
  (h : Π i, F i) (x : direct_sum ι β) :
   direct_sum.map h x = direct_sum.mk γ (x.support)
   (zoto h x) :=
   -- (λ i, (h i) (x i))  gives `unknown fresh 0._ ` error
begin
  conv_lhs {rw ← direct_sum.sum_support_of β x, },
  rw map_sum,
  simp_rw direct_sum.map_of,
  apply symm,
  convert direct_sum.mk_eq_sum (x.support) (λ i, (h i) (x i)),
  apply funext,
  intro i,
  dsimp,

  apply congr_arg,
  split_ifs with hi,
  refl,
  rw dfinsupp.not_mem_support_iff at hi,
  rw hi, simp only [map_zero],

end

end direct_sum

section graded_quot

variables (R : Type*) [comm_ring R]
variables {ι : Type*} [decidable_eq ι] [add_monoid ι]
variables {A : Type*} [comm_ring A] [decidable_eq A] [algebra R A]

/- -- graded_algebra does not work with `submodule_class`

variables {σ : Type*} [set_like σ A] [add_submonoid_class σ A]
[submodule_class σ R A]

variable (𝒜 : ι → σ) [h𝒜 : graded_algebra 𝒜]
-/

section
variables {σ : Type*} [set_like σ A] [add_submonoid_class σ A]
[submodule_class σ R A]

#check graded_algebra

variables (ℬ : ι → σ)

@[reducible]
def graded_algebra' := @graded_ring _ A _ _ _ _ _ _ ℬ

variable [hℬ : graded_algebra' ℬ]

end

variables (𝒜 : ι → submodule R A)

variables (I : ideal A)

-- variables [h𝒜 : graded_algebra 𝒜] (hI: ideal.is_homogeneous 𝒜 I)

-- It seems I start understanding what I'm doing
example : semilinear_map_class (A →+* A ⧸ I) (ring_hom.id ℤ) _ _ :=
{ coe            := λ f a, f a,
  coe_injective' := λ f g hfg, ring_hom.ext (λ x, function.funext_iff.mp hfg x),
  map_add        := map_add,
  map_smulₛₗ     := λ f r a, by simp only [zsmul_eq_mul, map_mul, map_int_cast, eq_int_cast, int.cast_id], }

-- This will probably be useless in the end, because I "R-modulify" everything

-- ideal.quotient.mk vs ideal.quotient.mkₐ
example (I : ideal A) (r : R) (a : A) :
  r • (ideal.quotient.mk I a) = ideal.quotient.mk I (r • a) :=
  map_smul (ideal.quotient.mkₐ R I) r a

/-- The graded pieces of A ⧸ I -/
def quot_submodule : ι → submodule R (A ⧸ I) := λ i, submodule.map (ideal.quotient.mkₐ R I) (𝒜 i)

/- broken by the passage to modules…
-- I think this one can be erased, since we have the laux version
/-- The decomposition at the higher level -/
def quot_decompose_aux [graded_ring 𝒜] :
  A → direct_sum ι (λ (i : ι), ↥(quot_submodule R 𝒜 I i)) := λ a,
begin
  refine (direct_sum.map _) (direct_sum.decompose_linear_equiv 𝒜 a),
  exact λ i, {
  to_fun := λu, ⟨ideal.quotient.mk I ↑u,
  begin
    simp [quot_submodule, submodule.mem_map],
    exact ⟨↑u, u.prop, rfl⟩,
  end⟩,
  map_zero' := by simp only [←subtype.coe_inj, submodule.coe_zero, map_zero, submodule.coe_mk],
  map_add' := λ u v, by simp only [←subtype.coe_inj, submodule.coe_add, map_add,
                add_mem_class.mk_add_mk] },
end
-/

def quot_comp_map (i : ι) : ↥(𝒜 i) →ₗ[R] ↥(quot_submodule R 𝒜 I i) :=
{ to_fun    := λ u, ⟨ideal.quotient.mkₐ R I ↑u,
                 by rw [quot_submodule,submodule.mem_map]; exact ⟨↑u, u.prop, rfl⟩⟩,
  map_add'  := λ u v, by simp only [←subtype.coe_inj, submodule.coe_add, map_add,
                 add_mem_class.mk_add_mk],
  map_smul' := λ r u, by simp only [submodule.coe_smul_of_tower, ring_hom.id_apply, set_like.mk_smul_mk, subtype.mk_eq_mk, map_smul], }

-- lemma quot_comp_map_surjective (i : ι) : function.surjective (quot_comp_map R 𝒜 I i) := sorry

example : submodule R A := I.restrict_scalars R

/-- The decomposition at the higher level -/
def quot_decompose_laux [graded_algebra 𝒜]:
  A →ₗ[R] direct_sum ι (λ (i : ι), ↥(quot_submodule R 𝒜 I i)) :=
linear_map.comp (direct_sum.lmap' (quot_comp_map R 𝒜 I))
  (direct_sum.decompose_alg_equiv 𝒜).to_linear_map

lemma quot_decompose_laux_of_mem_eq_zero [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) (x : A) (hx : x ∈ I) (i : ι) :
((quot_decompose_laux R 𝒜 I) x) i = 0 :=
begin
  rw [quot_decompose_laux,linear_map.comp_apply,direct_sum.lmap'_apply, quot_comp_map],
  simp only [ideal.quotient.mkₐ_eq_mk, alg_equiv.to_linear_map_apply,
    direct_sum.decompose_alg_equiv_apply, linear_map.coe_mk,
    submodule.mk_eq_zero],
  rw ideal.quotient.eq_zero_iff_mem,
  exact hI i hx,
end

lemma quot_decompose_laux_ker [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) :
  I.restrict_scalars R ≤ (quot_decompose_laux R 𝒜 I).ker :=
begin
  intros x hx,
  simp only [submodule.restrict_scalars_mem] at hx,

  rw [linear_map.mem_ker],
  ext i,
  rw [direct_sum.zero_apply, submodule.coe_zero, submodule.coe_eq_zero],
  apply quot_decompose_laux_of_mem_eq_zero,
  exact hI, exact hx,
end

/-- The decomposition at the higher level -/
def quot_decompose [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) :
A ⧸ I →ₗ[R] direct_sum ι (λ (i : ι), ↥(quot_submodule R 𝒜 I i)) :=
begin
  apply @submodule.liftq R A _ _ _ (I.restrict_scalars R) R
    (direct_sum ι (λ i, quot_submodule R 𝒜 I i) ) _ _ _ (ring_hom.id R) (quot_decompose_laux R 𝒜 I),
 -- without explicit arguments, it is too slow
 -- apply submodule.liftq (I.restrict_scalars R) (quot_decompose_laux R 𝒜 I),
  apply quot_decompose_laux_ker R 𝒜 I hI,
end

lemma quot_decompose_laux_apply_mk [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) (a : A):
quot_decompose R 𝒜 I hI (ideal.quotient.mk I a) = quot_decompose_laux R 𝒜 I a :=
begin
  rw [quot_decompose],
  have : ideal.quotient.mk I a = submodule.quotient.mk a := rfl,
  rw this,
  -- with explicit arguments, it times out
  -- exact submodule.liftq_apply (I.restrict_scalars R) (quot_decompose_laux R 𝒜 I) a,
  -- apply works
  apply submodule.liftq_apply,
end

def quot_decomposition_left_inv [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) : function.left_inverse
(direct_sum.coe_add_monoid_hom (quot_submodule R 𝒜 I)) (quot_decompose R 𝒜 I hI) := λ a,
begin
  obtain ⟨a, rfl⟩ := (ideal.quotient.mk I).is_surjective a,

  rw quot_decompose_laux_apply_mk,
  rw quot_decompose_laux,
  simp only [linear_map.comp_apply],

  let h𝒜 : direct_sum.decomposition 𝒜  := by apply_instance,
  let ha := h𝒜.left_inv a,
  have : (direct_sum.decompose_alg_equiv 𝒜).to_linear_map a
    = direct_sum.decomposition.decompose' a,
    refl,
  rw this,
  conv_rhs {rw ← h𝒜.left_inv a},

  change _ = submodule.mkq (I.restrict_scalars R)  (_),
  simp only [←linear_map.to_add_monoid_hom_coe],

  rw direct_sum.lmap'_to_add_monoid_hom_eq_map',
  simp only [← add_monoid_hom.comp_apply],
  generalize : direct_sum.decomposition.decompose' a = b,
  revert b,
  rw ← add_monoid_hom.ext_iff,
  apply direct_sum.add_hom_ext,
  intros i y,
  simp only [add_monoid_hom.coe_comp, function.comp_app, linear_map.to_add_monoid_hom_coe, direct_sum.coe_add_monoid_hom_of,
  submodule.mkq_apply],
  rw direct_sum.map'_of,
  rw direct_sum.coe_add_monoid_hom_of,
  simp only [linear_map.to_add_monoid_hom_coe],
  rw [quot_comp_map],
  simp only [ideal.quotient.mkₐ_eq_mk, linear_map.coe_mk, submodule.coe_mk],
  refl,
end

def quot_decomposition_right_inv [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) : function.right_inverse
(direct_sum.coe_add_monoid_hom (quot_submodule R 𝒜 I)) (quot_decompose R 𝒜 I hI) := λ x,
begin
  simp only [←linear_map.to_add_monoid_hom_coe],
  rw ← add_monoid_hom.comp_apply,
  conv_rhs {rw ← add_monoid_hom.id_apply _ x},
  revert x,
  rw ← add_monoid_hom.ext_iff,
  apply direct_sum.add_hom_ext,
  intros i y,
  obtain ⟨x, hx, hxy⟩ := y.prop,

  simp only [add_monoid_hom.coe_comp, linear_map.to_add_monoid_hom_coe, function.comp_app, direct_sum.coe_add_monoid_hom_of,
  add_monoid_hom.id_apply],
  rw ←hxy,
  rw ideal.quotient.mkₐ_eq_mk,
  rw quot_decompose_laux_apply_mk,

  rw quot_decompose_laux,
  simp only [linear_map.coe_comp, function.comp_app, alg_equiv.to_linear_map_apply, direct_sum.decompose_alg_equiv_apply],

  change direct_sum.lmap' _ (direct_sum.decompose 𝒜 x) = _,
  suffices : direct_sum.decompose 𝒜 x = direct_sum.lof R ι (λ i, 𝒜 i) i (⟨x, hx⟩ : 𝒜 i),
  rw this,
  rw direct_sum.lmap'_lof,
  rw direct_sum.lof_eq_of,
  apply congr_arg2 _ rfl,
  rw quot_comp_map,
  simp only [ideal.quotient.mkₐ_eq_mk, submodule.coe_mk, linear_map.coe_mk],
  rw [←subtype.coe_inj, subtype.coe_mk],
  rw ←hxy,
  simp only [ideal.quotient.mkₐ_eq_mk],

  conv_lhs {rw ← subtype.coe_mk x hx },
  rw direct_sum.decompose_coe,
  rw direct_sum.lof_eq_of,
end

def quot_decomposition [graded_algebra 𝒜] (hI : I.is_homogeneous 𝒜) :
  direct_sum.decomposition (quot_submodule R 𝒜 I) :=
{ decompose' := quot_decompose R 𝒜 I hI,
  left_inv   := quot_decomposition_left_inv R 𝒜 I hI,
  right_inv  := quot_decomposition_right_inv R 𝒜 I hI }

lemma mem_quot_submodule_iff (i : ι) (g : A ⧸ I):
  g ∈ quot_submodule R 𝒜 I i ↔ ∃ (a : A), a ∈ 𝒜 i ∧ideal.quotient.mk I a = g   :=
by rw [quot_submodule, submodule.mem_map, ideal.quotient.mkₐ_eq_mk]

/-- The quotient of a graded algebra by a homogeneous ideal, as a graded algebra -/
def graded_quot_alg [graded_algebra 𝒜]
  (hI : I.is_homogeneous 𝒜) :
  graded_algebra (quot_submodule R 𝒜 I) :=
{ to_decomposition  := quot_decomposition R 𝒜 I hI,
  to_graded_monoid  :=
  { one_mem := by rw [quot_submodule, submodule.mem_map]; exact ⟨1, set_like.one_mem_graded 𝒜, rfl⟩,
    mul_mem := λ i j gi gj hgi hgj,
    begin
    rw mem_quot_submodule_iff at hgi hgj ⊢,
    obtain ⟨ai, hai, rfl⟩ := hgi,
    obtain ⟨aj, haj, rfl⟩ := hgj,
    exact ⟨ai * aj, set_like.mul_mem_graded hai haj,
    map_mul _ _ _⟩,
    end
    }}

#exit
-- variable (rel : A → A → Prop)

-- open_locale big_operators

/-
def weights [graded_ring 𝒜] [Π (i : ι) (x : ↥(𝒜 i)), decidable (x ≠ 0)] (a : A) :=
dfinsupp.support (direct_sum.decompose 𝒜 a)

def is_homogenous [graded_ring 𝒜] [Π (i : ι) (x : ↥(𝒜 i)), decidable (x ≠ 0)] (a : A) :=
subsingleton (weights 𝒜 a)
-/

example (R S : Type*) [comm_ring R] [comm_ring S] (f : R →+* S)
 (I : submonoid R) : submonoid S :=  submonoid.map f I

example (R : Type*) [comm_ring R] (I : ideal R) (M : ideal R) : ideal (R ⧸ I) :=
ideal.map (ideal.quotient.mk I) M

example (R S : Type*) [comm_ring R] [comm_ring S] (f : R →+* S)
 (I : ideal R) : ideal S := ideal.map f I

def graded_quot_submonoid (𝒜 : ι → σ) : ι → add_submonoid (A ⧸ I) :=
λ i, add_submonoid.map (ideal.quotient.mk I) ⟨𝒜 i, λ _ _, add_mem, zero_mem _⟩

def graded_quot_submonoid' (𝒜 : ι → submodule ℤ A) : ι → add_submonoid (A ⧸ I) :=
begin
  sorry
  --haveI :
  --exact λ i, submodule.map (ideal.quotient.mk I) (𝒜 i)
end

example (i : ι) : add_comm_monoid (graded_quot_submonoid I 𝒜 i) :=
infer_instance

noncomputable
def quot_some : A ⧸ I → A := function.surj_inv (ideal.quotient.mk_surjective)

example (a : A ⧸ I) : ideal.quotient.mk I (quot_some I a) = a :=
  function.surj_inv_eq _ _

noncomputable
def toto := λ a i, ideal.quotient.mk I ((h𝒜.decompose' (quot_some I a)) i)

noncomputable
def tata := λ a, dfinsupp.support (h𝒜.decompose' (quot_some I a))

lemma direct_sum.comp_to_add_monoid {ι : Type*} [dec_ι : decidable_eq ι] {β : ι → Type*}
  [Π (i : ι), add_comm_monoid (β i)] {γ δ : Type*} [add_comm_monoid γ] [add_comm_monoid δ]
  (f : γ →+ δ) (φ : Π (i : ι), β i →+ γ) :
  f.comp (direct_sum.to_add_monoid φ) = direct_sum.to_add_monoid (λ i, f.comp (φ i)) :=
begin
  apply direct_sum.add_hom_ext,
  intros i y,
  simp only [direct_sum.to_add_monoid_of, add_monoid_hom.coe_comp, function.comp_app],
end

example {ι : Type*} [dec_ι : decidable_eq ι] {β : ι → Type*} [Π (i : ι), add_comm_monoid (β i)]
  {γ δ : Type*} [add_comm_monoid γ] [add_comm_monoid δ] (f : γ →+ δ) (φ : Π (i : ι), β i →+ γ)
  (x : direct_sum ι β) :
  f (direct_sum.to_add_monoid φ x) = direct_sum.to_add_monoid (λ i, f.comp (φ i)) x :=
by rw [← add_monoid_hom.comp_apply, direct_sum.comp_to_add_monoid]

instance asdf : Π (i : ι), add_comm_monoid ((λ (i : ι), ↥(graded_quot_submonoid I 𝒜 i)) i) := sorry
example  [Π (x : A), decidable (x ≠ 0)]
  [Π (i : ι) (x : ↥(graded_quot_submonoid I 𝒜 i)), decidable (x ≠ 0)]
  [decidable_pred (λ x, x ∈ I)] :
  -- [h𝒜 : graded_ring 𝒜] :
  A → direct_sum ι (λ (i : ι), ↥(graded_quot_submonoid I 𝒜 i)) := λ a,
begin
  haveI : Π i, add_comm_monoid (𝒜 i), intro i, apply_instance,
  suffices hh : direct_sum ι (λ i, 𝒜 i) →+ direct_sum ι (λ i, graded_quot_submonoid I 𝒜 i),

  sorry,
  -- exact hh (direct_sum.decompose 𝒜 a),

  apply direct_sum.map,
  /- intro i,
  let h : Π i, (𝒜 i) →+ graded_quot_submonoid 𝒜 I i :=
  -/
  exact λ i, {
  to_fun := λu,
  begin
    use ideal.quotient.mk I ↑u,
    simp only [graded_quot_submonoid, add_submonoid.mem_map, add_submonoid.mem_mk, set_like.mem_coe,
      exists_prop],
    exact ⟨↑u, u.prop, rfl⟩,
  end,
  map_zero' :=
  begin
    rw ←subtype.coe_inj,
    simp only [add_submonoid.coe_zero, map_zero, set_like.coe_mk],
    sorry

--    simp only [zero_mem_class.coe_eq_zero],

--    simp only [zero_mem_class.coe_zero, map_zero, set_like.coe_mk],
  end,
  map_add' := λ u v,
  begin
    rw ←subtype.coe_inj,
    sorry --simp only [add_mem_class.coe_add, map_add, add_submonoid.mk_add_mk],
  end, },
  /- haveI : Π i, add_comm_monoid (𝒜 i), intro i, apply_instance,
  have hh : direct_sum ι (λ i, 𝒜 i) →+ direct_sum ι (λ i, graded_quot_submonoid 𝒜 I i),
  apply direct_sum.map, -/

end

example [Π (x : A), decidable (x ≠ 0)]
 [Π (i : ι) (x : ↥(graded_quot_submonoid I 𝒜 i)), decidable (x ≠ 0)]
 [decidable_pred (λ x, x ∈ I)] :
  direct_sum.decomposition (graded_quot_submonoid I 𝒜) := sorry/-  {
decompose'  :=
/- direct_sum.mk
  (λ i, (graded_quot_submonoid 𝒜 I i))
  (dfinsupp.support (h𝒜.decompose' (quot_some I a)))
  (λ i, ⟨ideal.quotient.mk I ((h𝒜.decompose' (quot_some I a)) i),
   add_submonoid.mem_map_of_mem _ (by
    simp only [subtype.val_eq_coe, add_submonoid.mem_mk, set_like.mem_coe, set_like.coe_mem])⟩), -/
  begin
    sorry
  end,

left_inv    := λ a,
begin
  /- have : ideal.quotient.mk I (quot_some I a) = a :=
  function.surj_inv_eq _ _,
  conv_rhs { rw ← this, rw ← h𝒜.left_inv (quot_some I a), },

  dsimp only,

  generalize : direct_sum.decomposition.decompose' (quot_some I a) = b,
  resetI,
  rw [direct_sum.to_add_monoid.unique],

  rw ← add_monoid_hom.comp_apply,
  have : (ideal.quotient.mk I) ((direct_sum.coe_add_monoid_hom 𝒜) b) =
    (ideal.quotient.mk I).to_add_monoid_hom.comp (direct_sum.coe_add_monoid_hom 𝒜) b,
  rw add_monoid_hom.comp_apply, refl,
  rw this,

  dsimp,

simp_rw direct_sum.to_add_monoid_mk,

  have : ∀ i, (direct_sum.coe_add_monoid_hom (graded_quot_submonoid 𝒜 I)).comp
  (direct_sum.of (λ (i : ι), ↥(graded_quot_submonoid 𝒜 I i)) i) = _,  -/sorry,

end,
right_inv   := λ a,
begin
  dsimp,
  ext i,
  sorry,
end } -/

--sorry
/- def graded_ring_quot : graded_ring (graded_quot_submonoid 𝒜 I hI) :=
sorry

#check graded_quot

example (I : ideal A) [graded_ring 𝒜] (hI: ideal.is_homogeneous 𝒜 I) :
  graded_algebra (graded_quot 𝒜 I hI) :=
begin
end -/

end graded_quot


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.basic
import category_theory.conj

/-!
# Mate of natural transformations

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

This file establishes the bijection between the 2-cells

         L₁                  R₁
      C --→ D             C ←-- D
    G ↓  ↗  ↓ H         G ↓  ↘  ↓ H
      E --→ F             E ←-- F
         L₂                  R₂

where `L₁ ⊣ R₁` and `L₂ ⊣ R₂`, and shows that in the special case where `G,H` are identity then the
bijection preserves and reflects isomorphisms (i.e. we have bijections `(L₂ ⟶ L₁) ≃ (R₁ ⟶ R₂)`, and
if either side is an iso then the other side is as well).

On its own, this bijection is not particularly useful but it includes a number of interesting cases
as specializations.

For instance, this generalises the fact that adjunctions are unique (since if `L₁ ≅ L₂` then we
deduce `R₁ ≅ R₂`).
Another example arises from considering the square representing that a functor `H` preserves
products, in particular the morphism `HA ⨯ H- ⟶ H(A ⨯ -)`. Then provided `(A ⨯ -)` and `HA ⨯ -` have
left adjoints (for instance if the relevant categories are cartesian closed), the transferred
natural transformation is the exponential comparison morphism: `H(A ^ -) ⟶ HA ^ H-`.
Furthermore if `H` has a left adjoint `L`, this morphism is an isomorphism iff its mate
`L(HA ⨯ -) ⟶ A ⨯ L-` is an isomorphism, see
https://ncatlab.org/nlab/show/Frobenius+reciprocity#InCategoryTheory.
This also relates to Grothendieck's yoga of six operations, though this is not spelled out in
mathlib: https://ncatlab.org/nlab/show/six+operations.
-/
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

namespace category_theory
open category

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]

section square

variables {E : Type u₃} {F : Type u₄} [category.{v₃} E] [category.{v₄} F]

variables {G : C ⥤ E} {H : D ⥤ F} {L₁ : C ⥤ D} {R₁ : D ⥤ C} {L₂ : E ⥤ F} {R₂ : F ⥤ E}
variables (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)

include adj₁ adj₂

/--
Suppose we have a square of functors (where the top and bottom are adjunctions `L₁ ⊣ R₁` and
`L₂ ⊣ R₂` respectively).

      C ↔ D
    G ↓   ↓ H
      E ↔ F

Then we have a bijection between natural transformations `G ⋙ L₂ ⟶ L₁ ⋙ H` and
`R₁ ⋙ G ⟶ H ⋙ R₂`.
This can be seen as a bijection of the 2-cells:

         L₁                  R₁
      C --→ D             C ←-- D
    G ↓  ↗  ↓ H         G ↓  ↘  ↓ H
      E --→ F             E ←-- F
         L₂                  R₂

Note that if one of the transformations is an iso, it does not imply the other is an iso.
-/
def transfer_nat_trans : (G ⋙ L₂ ⟶ L₁ ⋙ H) ≃ (R₁ ⋙ G ⟶ H ⋙ R₂) :=
{ to_fun := λ h,
  { app := λ X, adj₂.unit.app _ ≫ R₂.map (h.app _ ≫ H.map (adj₁.counit.app _)),
    naturality' := λ X Y f,
    begin
      dsimp,
      rw [assoc, ← R₂.map_comp, assoc, ← H.map_comp, ← adj₁.counit_naturality, H.map_comp,
          ←functor.comp_map L₁, ←h.naturality_assoc],
      simp,
    end },
  inv_fun := λ h,
  { app := λ X, L₂.map (G.map (adj₁.unit.app _) ≫ h.app _) ≫ adj₂.counit.app _,
  naturality' := λ X Y f,
  begin
    dsimp,
    rw [← L₂.map_comp_assoc, ← G.map_comp_assoc, ← adj₁.unit_naturality, G.map_comp_assoc,
        ← functor.comp_map, h.naturality],
    simp,
  end },
  left_inv := λ h,
  begin
    ext X,
    dsimp,
    simp only [L₂.map_comp, assoc, adj₂.counit_naturality, adj₂.left_triangle_components_assoc,
      ←functor.comp_map G L₂, h.naturality_assoc, functor.comp_map L₁, ←H.map_comp,
      adj₁.left_triangle_components],
    dsimp,
    simp, -- See library note [dsimp, simp].
  end,
  right_inv := λ h,
  begin
    ext X,
    dsimp,
    simp [-functor.comp_map, ←functor.comp_map H, functor.comp_map R₁, -nat_trans.naturality,
      ←h.naturality, -functor.map_comp, ←functor.map_comp_assoc G, R₂.map_comp],
  end }

lemma transfer_nat_trans_counit (f : G ⋙ L₂ ⟶ L₁ ⋙ H) (Y : D) :
  L₂.map ((transfer_nat_trans adj₁ adj₂ f).app _) ≫ adj₂.counit.app _ =
    f.app _ ≫ H.map (adj₁.counit.app Y) :=
by { erw functor.map_comp, simp }

lemma unit_transfer_nat_trans (f : G ⋙ L₂ ⟶ L₁ ⋙ H) (X : C) :
  G.map (adj₁.unit.app X) ≫ (transfer_nat_trans adj₁ adj₂ f).app _ =
    adj₂.unit.app _ ≫ R₂.map (f.app _) :=
begin
  dsimp [transfer_nat_trans],
  rw [←adj₂.unit_naturality_assoc, ←R₂.map_comp, ← functor.comp_map G L₂, f.naturality_assoc,
    functor.comp_map, ← H.map_comp],
  dsimp, simp, -- See library note [dsimp, simp]
end

end square

section self

variables {L₁ L₂ L₃ : C ⥤ D} {R₁ R₂ R₃ : D ⥤ C}
variables (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂) (adj₃ : L₃ ⊣ R₃)

/--
Given two adjunctions `L₁ ⊣ R₁` and `L₂ ⊣ R₂` both between categories `C`, `D`, there is a
bijection between natural transformations `L₂ ⟶ L₁` and natural transformations `R₁ ⟶ R₂`.
This is defined as a special case of `transfer_nat_trans`, where the two "vertical" functors are
identity.
TODO: Generalise to when the two vertical functors are equivalences rather than being exactly `𝟭`.

Furthermore, this bijection preserves (and reflects) isomorphisms, i.e. a transformation is an iso
iff its image under the bijection is an iso, see eg `category_theory.transfer_nat_trans_self_iso`.
This is in contrast to the general case `transfer_nat_trans` which does not in general have this
property.
-/
def transfer_nat_trans_self : (L₂ ⟶ L₁) ≃ (R₁ ⟶ R₂) :=
calc (L₂ ⟶ L₁) ≃ _         : (iso.hom_congr L₂.left_unitor L₁.right_unitor).symm
           ... ≃ _         : transfer_nat_trans adj₁ adj₂
           ... ≃ (R₁ ⟶ R₂) : R₁.right_unitor.hom_congr R₂.left_unitor

lemma transfer_nat_trans_self_counit (f : L₂ ⟶ L₁) (X) :
  L₂.map ((transfer_nat_trans_self adj₁ adj₂ f).app _) ≫ adj₂.counit.app X =
    f.app _ ≫ adj₁.counit.app X :=
begin
  dsimp [transfer_nat_trans_self],
  rw [id_comp, comp_id],
  have := transfer_nat_trans_counit adj₁ adj₂ (L₂.left_unitor.hom ≫ f ≫ L₁.right_unitor.inv) X,
  dsimp at this,
  rw this,
  simp,
end

lemma unit_transfer_nat_trans_self (f : L₂ ⟶ L₁) (X) :
  adj₁.unit.app _ ≫ (transfer_nat_trans_self adj₁ adj₂ f).app _ =
    adj₂.unit.app X ≫ functor.map _ (f.app _) :=
begin
  dsimp [transfer_nat_trans_self],
  rw [id_comp, comp_id],
  have := unit_transfer_nat_trans adj₁ adj₂ (L₂.left_unitor.hom ≫ f ≫ L₁.right_unitor.inv) X,
  dsimp at this,
  rw this,
  simp
end

@[simp]
lemma transfer_nat_trans_self_id : transfer_nat_trans_self adj₁ adj₁ (𝟙 _) = 𝟙 _ :=
by { ext, dsimp [transfer_nat_trans_self, transfer_nat_trans], simp }
  -- See library note [dsimp, simp]

@[simp]
lemma transfer_nat_trans_self_symm_id :
  (transfer_nat_trans_self adj₁ adj₁).symm (𝟙 _) = 𝟙 _ :=
by { rw equiv.symm_apply_eq, simp }

lemma transfer_nat_trans_self_comp (f g) :
  transfer_nat_trans_self adj₁ adj₂ f ≫ transfer_nat_trans_self adj₂ adj₃ g =
    transfer_nat_trans_self adj₁ adj₃ (g ≫ f) :=
begin
  ext,
  dsimp [transfer_nat_trans_self, transfer_nat_trans],
  simp only [id_comp, comp_id],
  rw [←adj₃.unit_naturality_assoc, ←R₃.map_comp, g.naturality_assoc, L₂.map_comp, assoc,
    adj₂.counit_naturality, adj₂.left_triangle_components_assoc, assoc],
end

lemma transfer_nat_trans_self_adjunction_id {L R : C ⥤ C} (adj : L ⊣ R) (f : 𝟭 C ⟶ L) (X : C) :
  (transfer_nat_trans_self adj adjunction.id f).app X = f.app (R.obj X) ≫ adj.counit.app X :=
begin
  dsimp [transfer_nat_trans_self, transfer_nat_trans, adjunction.id],
  simp only [comp_id, id_comp],
end

lemma transfer_nat_trans_self_adjunction_id_symm {L R : C ⥤ C} (adj : L ⊣ R) (g : R ⟶ 𝟭 C)
  (X : C) : ((transfer_nat_trans_self adj adjunction.id).symm g).app X =
  adj.unit.app X ≫ (g.app (L.obj X)) :=
begin
  dsimp [transfer_nat_trans_self, transfer_nat_trans, adjunction.id],
  simp only [comp_id, id_comp],
end

lemma transfer_nat_trans_self_symm_comp (f g) :
  (transfer_nat_trans_self adj₂ adj₁).symm f ≫ (transfer_nat_trans_self adj₃ adj₂).symm g =
    (transfer_nat_trans_self adj₃ adj₁).symm (g ≫ f) :=
by { rw [equiv.eq_symm_apply, ← transfer_nat_trans_self_comp _ adj₂], simp }

lemma transfer_nat_trans_self_comm {f g} (gf : g ≫ f = 𝟙 _) :
  transfer_nat_trans_self adj₁ adj₂ f ≫ transfer_nat_trans_self adj₂ adj₁ g = 𝟙 _ :=
by rw [transfer_nat_trans_self_comp, gf, transfer_nat_trans_self_id]

lemma transfer_nat_trans_self_symm_comm {f g} (gf : g ≫ f = 𝟙 _) :
  (transfer_nat_trans_self adj₁ adj₂).symm f ≫ (transfer_nat_trans_self adj₂ adj₁).symm g = 𝟙 _ :=
by rw [transfer_nat_trans_self_symm_comp, gf, transfer_nat_trans_self_symm_id]

/--
If `f` is an isomorphism, then the transferred natural transformation is an isomorphism.
The converse is given in `transfer_nat_trans_self_of_iso`.
-/
instance transfer_nat_trans_self_iso (f : L₂ ⟶ L₁) [is_iso f] :
  is_iso (transfer_nat_trans_self adj₁ adj₂ f) :=
⟨⟨transfer_nat_trans_self adj₂ adj₁ (inv f),
  ⟨transfer_nat_trans_self_comm _ _ (by simp), transfer_nat_trans_self_comm _ _ (by simp)⟩⟩⟩

/--
If `f` is an isomorphism, then the un-transferred natural transformation is an isomorphism.
The converse is given in `transfer_nat_trans_self_symm_of_iso`.
-/
instance transfer_nat_trans_self_symm_iso (f : R₁ ⟶ R₂) [is_iso f] :
  is_iso ((transfer_nat_trans_self adj₁ adj₂).symm f) :=
⟨⟨(transfer_nat_trans_self adj₂ adj₁).symm (inv f),
  ⟨transfer_nat_trans_self_symm_comm _ _ (by simp),
   transfer_nat_trans_self_symm_comm _ _ (by simp)⟩⟩⟩

/--
If `f` is a natural transformation whose transferred natural transformation is an isomorphism,
then `f` is an isomorphism.
The converse is given in `transfer_nat_trans_self_iso`.
-/
lemma transfer_nat_trans_self_of_iso (f : L₂ ⟶ L₁) [is_iso (transfer_nat_trans_self adj₁ adj₂ f)] :
  is_iso f :=
begin
  suffices :
    is_iso ((transfer_nat_trans_self adj₁ adj₂).symm (transfer_nat_trans_self adj₁ adj₂ f)),
  { simpa using this },
  apply_instance,
end

/--
If `f` is a natural transformation whose un-transferred natural transformation is an isomorphism,
then `f` is an isomorphism.
The converse is given in `transfer_nat_trans_self_symm_iso`.
-/

end self

end category_theory


/-
Copyright (c) 2021 Yourong Zang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yourong Zang

! This file was ported from Lean 3 source module analysis.inner_product_space.conformal_linear_map
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.ConformalLinearMap
import Mathbin.Analysis.InnerProductSpace.Basic

/-!
# Conformal maps between inner product spaces

In an inner product space, a map is conformal iff it preserves inner products up to a scalar factor.
-/

variable {E F : Type _}

variable [NormedAddCommGroup E] [NormedAddCommGroup F]

variable [InnerProductSpace ℝ E] [InnerProductSpace ℝ F]

open LinearIsometry ContinuousLinearMap

open RealInnerProductSpace

/-- A map between two inner product spaces is a conformal map if and only if it preserves inner
products up to a scalar factor, i.e., there exists a positive `c : ℝ` such that `⟪f u, f v⟫ = c *
⟪u, v⟫` for all `u`, `v`. -/
theorem isConformalMap_iff (f : E →L[ℝ] F) :
    IsConformalMap f ↔ ∃ c : ℝ, 0 < c ∧ ∀ u v : E, ⟪f u, f v⟫ = c * ⟪u, v⟫ :=
  by
  constructor
  · rintro ⟨c₁, hc₁, li, rfl⟩
    refine' ⟨c₁ * c₁, mul_self_pos.2 hc₁, fun u v => _⟩
    simp only [real_inner_smul_left, real_inner_smul_right, mul_assoc, coe_smul',
      coe_to_continuous_linear_map, Pi.smul_apply, inner_map_map]
  · rintro ⟨c₁, hc₁, huv⟩
    obtain ⟨c, hc, rfl⟩ : ∃ c : ℝ, 0 < c ∧ c₁ = c * c
    exact ⟨Real.sqrt c₁, Real.sqrt_pos.2 hc₁, (Real.mul_self_sqrt hc₁.le).symm⟩
    refine' ⟨c, hc.ne', (c⁻¹ • f : E →ₗ[ℝ] F).isometryOfInner fun u v => _, _⟩
    ·
      simp only [real_inner_smul_left, real_inner_smul_right, huv, mul_assoc, coe_smul,
        inv_mul_cancel_left₀ hc.ne', LinearMap.smul_apply, ContinuousLinearMap.coe_coe]
    · ext1 x
      exact (smul_inv_smul₀ hc.ne' (f x)).symm
#align is_conformal_map_iff isConformalMap_iff