/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import analysis.inner_product_space.basic
import measure_theory.integral.set_integral

/-! # `L^2` space

If `E` is an inner product space over `𝕜` (`ℝ` or `ℂ`), then `Lp E 2 μ` (defined in `lp_space.lean`)
is also an inner product space, with inner product defined as `inner f g = ∫ a, ⟪f a, g a⟫ ∂μ`.

### Main results

* `mem_L1_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  belongs to `Lp 𝕜 1 μ`.
* `integrable_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  is integrable.
* `L2.inner_product_space` : `Lp E 2 μ` is an inner product space.

-/

noncomputable theory
open topological_space measure_theory measure_theory.Lp
open_locale nnreal ennreal measure_theory

namespace measure_theory

section

variables {α F : Type*} {m : measurable_space α} {μ : measure α} [normed_group F]

lemma mem_ℒp.integrable_sq {f : α → ℝ} (h : mem_ℒp f 2 μ) :
  integrable (λ x, (f x)^2) μ :=
by simpa [← mem_ℒp_one_iff_integrable]
  using h.norm_rpow ennreal.two_ne_zero ennreal.two_ne_top

lemma mem_ℒp_two_iff_integrable_sq_norm {f : α → F} (hf : ae_strongly_measurable f μ) :
  mem_ℒp f 2 μ ↔ integrable (λ x, ∥f x∥^2) μ :=
begin
  rw ← mem_ℒp_one_iff_integrable,
  convert (mem_ℒp_norm_rpow_iff hf ennreal.two_ne_zero ennreal.two_ne_top).symm,
  { simp },
  { rw [div_eq_mul_inv, ennreal.mul_inv_cancel ennreal.two_ne_zero ennreal.two_ne_top] }
end

lemma mem_ℒp_two_iff_integrable_sq {f : α → ℝ} (hf : ae_strongly_measurable f μ) :
  mem_ℒp f 2 μ ↔ integrable (λ x, (f x)^2) μ :=
begin
  convert mem_ℒp_two_iff_integrable_sq_norm hf,
  ext x,
  simp,
end

end

namespace L2

variables {α E F 𝕜 : Type*} [is_R_or_C 𝕜] [measurable_space α] {μ : measure α}
  [inner_product_space 𝕜 E] [normed_group F]

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

lemma snorm_rpow_two_norm_lt_top (f : Lp F 2 μ) : snorm (λ x, ∥f x∥ ^ (2 : ℝ)) 1 μ < ∞ :=
begin
  have h_two : ennreal.of_real (2 : ℝ) = 2, by simp [zero_le_one],
  rw [snorm_norm_rpow f zero_lt_two, one_mul, h_two],
  exact ennreal.rpow_lt_top_of_nonneg zero_le_two (Lp.snorm_ne_top f),
end

lemma snorm_inner_lt_top (f g : α →₂[μ] E) : snorm (λ (x : α), ⟪f x, g x⟫) 1 μ < ∞ :=
begin
  have h : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ ∥f x∥ * ∥g x∥, from λ x, abs_inner_le_norm _ _,
  have h' : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ is_R_or_C.abs (∥f x∥^2 + ∥g x∥^2),
  { refine λ x, le_trans (h x) _,
    rw [is_R_or_C.abs_to_real, abs_eq_self.mpr],
    swap, { exact add_nonneg (by simp) (by simp), },
    refine le_trans _ (half_le_self (add_nonneg (sq_nonneg _) (sq_nonneg _))),
    refine (le_div_iff (@zero_lt_two ℝ _ _)).mpr ((le_of_eq _).trans (two_mul_le_add_sq _ _)),
    ring, },
  simp_rw [← is_R_or_C.norm_eq_abs, ← real.rpow_nat_cast] at h',
  refine (snorm_mono_ae (ae_of_all _ h')).trans_lt ((snorm_add_le _ _ le_rfl).trans_lt _),
  { exact ((Lp.ae_strongly_measurable f).norm.ae_measurable.pow_const _).ae_strongly_measurable },
  { exact ((Lp.ae_strongly_measurable g).norm.ae_measurable.pow_const _).ae_strongly_measurable },
  simp only [nat.cast_bit0, ennreal.add_lt_top, nat.cast_one],
  exact ⟨snorm_rpow_two_norm_lt_top f, snorm_rpow_two_norm_lt_top g⟩,
end

section inner_product_space
open_locale complex_conjugate

include 𝕜

instance : has_inner 𝕜 (α →₂[μ] E) := ⟨λ f g, ∫ a, ⟪f a, g a⟫ ∂μ⟩

lemma inner_def (f g : α →₂[μ] E) : ⟪f, g⟫ = ∫ a : α, ⟪f a, g a⟫ ∂μ := rfl

lemma integral_inner_eq_sq_snorm (f : α →₂[μ] E) :
  ∫ a, ⟪f a, f a⟫ ∂μ = ennreal.to_real ∫⁻ a, (∥f a∥₊ : ℝ≥0∞) ^ (2:ℝ) ∂μ :=
begin
  simp_rw inner_self_eq_norm_sq_to_K,
  norm_cast,
  rw integral_eq_lintegral_of_nonneg_ae,
  rotate,
  { exact filter.eventually_of_forall (λ x, sq_nonneg _), },
  { exact ((Lp.ae_strongly_measurable f).norm.ae_measurable.pow_const _).ae_strongly_measurable },
  congr,
  ext1 x,
  have h_two : (2 : ℝ) = ((2 : ℕ) : ℝ), by simp,
  rw [← real.rpow_nat_cast _ 2, ← h_two,
    ← ennreal.of_real_rpow_of_nonneg (norm_nonneg _) zero_le_two, of_real_norm_eq_coe_nnnorm],
  norm_cast,
end

private lemma norm_sq_eq_inner' (f : α →₂[μ] E) : ∥f∥ ^ 2 = is_R_or_C.re ⟪f, f⟫ :=
begin
  have h_two : (2 : ℝ≥0∞).to_real = 2 := by simp,
  rw [inner_def, integral_inner_eq_sq_snorm, norm_def, ← ennreal.to_real_pow, is_R_or_C.of_real_re,
    ennreal.to_real_eq_to_real (ennreal.pow_ne_top (Lp.snorm_ne_top f)) _],
  { rw [←ennreal.rpow_nat_cast, snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top, snorm',
      ← ennreal.rpow_mul, one_div, h_two],
    simp, },
  { refine (lintegral_rpow_nnnorm_lt_top_of_snorm'_lt_top zero_lt_two _).ne,
    rw [← h_two, ← snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top],
    exact Lp.snorm_lt_top f, },
end

lemma mem_L1_inner (f g : α →₂[μ] E) :
  ae_eq_fun.mk (λ x, ⟪f x, g x⟫)
    ((Lp.ae_strongly_measurable f).inner (Lp.ae_strongly_measurable g)) ∈ Lp 𝕜 1 μ :=
by { simp_rw [mem_Lp_iff_snorm_lt_top, snorm_ae_eq_fun], exact snorm_inner_lt_top f g, }

lemma integrable_inner (f g : α →₂[μ] E) : integrable (λ x : α, ⟪f x, g x⟫) μ :=
(integrable_congr (ae_eq_fun.coe_fn_mk (λ x, ⟪f x, g x⟫)
    ((Lp.ae_strongly_measurable f).inner (Lp.ae_strongly_measurable g)))).mp
  (ae_eq_fun.integrable_iff_mem_L1.mpr (mem_L1_inner f g))

private lemma add_left' (f f' g : α →₂[μ] E) : ⟪f + f', g⟫ = inner f g + inner f' g :=
begin
  simp_rw [inner_def, ← integral_add (integrable_inner f g) (integrable_inner f' g),
    ←inner_add_left],
  refine integral_congr_ae ((coe_fn_add f f').mono (λ x hx, _)),
  congr,
  rwa pi.add_apply at hx,
end

private lemma smul_left' (f g : α →₂[μ] E) (r : 𝕜) :
  ⟪r • f, g⟫ = conj r * inner f g :=
begin
  rw [inner_def, inner_def, ← smul_eq_mul, ← integral_smul],
  refine integral_congr_ae ((coe_fn_smul r f).mono (λ x hx, _)),
  rw [smul_eq_mul, ← inner_smul_left],
  congr,
  rwa pi.smul_apply at hx,
end

instance inner_product_space : inner_product_space 𝕜 (α →₂[μ] E) :=
{ norm_sq_eq_inner := norm_sq_eq_inner',
  conj_sym := λ _ _, by simp_rw [inner_def, ← integral_conj, inner_conj_sym],
  add_left := add_left',
  smul_left := smul_left', }

end inner_product_space

section indicator_const_Lp

variables (𝕜) {s : set α}

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs c` and `f` is
equal to the integral of the inner product over `s`: `∫ x in s, ⟪c, f x⟫ ∂μ`. -/
lemma inner_indicator_const_Lp_eq_set_integral_inner (f : Lp E 2 μ) (hs : measurable_set s) (c : E)
  (hμs : μ s ≠ ∞) :
  (⟪indicator_const_Lp 2 hs hμs c, f⟫ : 𝕜) = ∫ x in s, ⟪c, f x⟫ ∂μ :=
begin
  rw [inner_def, ← integral_add_compl hs (L2.integrable_inner _ f)],
  have h_left : ∫ x in s, ⟪(indicator_const_Lp 2 hs hμs c) x, f x⟫ ∂μ = ∫ x in s, ⟪c, f x⟫ ∂μ,
  { suffices h_ae_eq : ∀ᵐ x ∂μ, x ∈ s → ⟪indicator_const_Lp 2 hs hμs c x, f x⟫ = ⟪c, f x⟫,
      from set_integral_congr_ae hs h_ae_eq,
    have h_indicator : ∀ᵐ (x : α) ∂μ, x ∈ s → (indicator_const_Lp 2 hs hμs c x) = c,
      from indicator_const_Lp_coe_fn_mem,
    refine h_indicator.mono (λ x hx hxs, _),
    congr,
    exact hx hxs, },
  have h_right : ∫ x in sᶜ, ⟪(indicator_const_Lp 2 hs hμs c) x, f x⟫ ∂μ = 0,
  { suffices h_ae_eq : ∀ᵐ x ∂μ, x ∉ s → ⟪indicator_const_Lp 2 hs hμs c x, f x⟫ = 0,
    { simp_rw ← set.mem_compl_iff at h_ae_eq,
      suffices h_int_zero : ∫ x in sᶜ, inner (indicator_const_Lp 2 hs hμs c x) (f x) ∂μ
        = ∫ x in sᶜ, (0 : 𝕜) ∂μ,
      { rw h_int_zero,
        simp, },
      exact set_integral_congr_ae hs.compl h_ae_eq, },
    have h_indicator : ∀ᵐ (x : α) ∂μ, x ∉ s → (indicator_const_Lp 2 hs hμs c x) = 0,
      from indicator_const_Lp_coe_fn_nmem,
    refine h_indicator.mono (λ x hx hxs, _),
    rw hx hxs,
    exact inner_zero_left, },
  rw [h_left, h_right, add_zero],
end

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs c` and `f` is
equal to the inner product of the constant `c` and the integral of `f` over `s`. -/
lemma inner_indicator_const_Lp_eq_inner_set_integral [complete_space E] [normed_space ℝ E]
  (hs : measurable_set s) (hμs : μ s ≠ ∞) (c : E) (f : Lp E 2 μ) :
  (⟪indicator_const_Lp 2 hs hμs c, f⟫ : 𝕜) = ⟪c, ∫ x in s, f x ∂μ⟫ :=
by rw [← integral_inner (integrable_on_Lp_of_measure_ne_top f fact_one_le_two_ennreal.elim hμs),
    L2.inner_indicator_const_Lp_eq_set_integral_inner]

variables {𝕜}

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs (1 : 𝕜)` and
a real or complex function `f` is equal to the integral of `f` over `s`. -/
lemma inner_indicator_const_Lp_one (hs : measurable_set s) (hμs : μ s ≠ ∞) (f : Lp 𝕜 2 μ) :
  ⟪indicator_const_Lp 2 hs hμs (1 : 𝕜), f⟫ = ∫ x in s, f x ∂μ :=
by { rw L2.inner_indicator_const_Lp_eq_inner_set_integral 𝕜 hs hμs (1 : 𝕜) f, simp, }

end indicator_const_Lp

end L2

section inner_continuous

variables {α : Type*} [topological_space α] [measure_space α] [borel_space α] {𝕜 : Type*}
  [is_R_or_C 𝕜]
variables (μ : measure α) [is_finite_measure μ]

open_locale bounded_continuous_function complex_conjugate

local notation `⟪`x`, `y`⟫` := @inner 𝕜 (α →₂[μ] 𝕜) _ x y

/-- For bounded continuous functions `f`, `g` on a finite-measure topological space `α`, the L^2
inner product is the integral of their pointwise inner product. -/
lemma bounded_continuous_function.inner_to_Lp (f g : α →ᵇ 𝕜) :
  ⟪bounded_continuous_function.to_Lp 2 μ 𝕜 f, bounded_continuous_function.to_Lp 2 μ 𝕜 g⟫
  = ∫ x, conj (f x) * g x ∂μ :=
begin
  apply integral_congr_ae,
  have hf_ae := f.coe_fn_to_Lp μ,
  have hg_ae := g.coe_fn_to_Lp μ,
  filter_upwards [hf_ae, hg_ae] with _ hf hg,
  rw [hf, hg],
  simp
end

variables [compact_space α]

/-- For continuous functions `f`, `g` on a compact, finite-measure topological space `α`, the L^2
inner product is the integral of their pointwise inner product. -/
lemma continuous_map.inner_to_Lp (f g : C(α, 𝕜)) :
  ⟪continuous_map.to_Lp 2 μ 𝕜 f, continuous_map.to_Lp 2 μ 𝕜 g⟫
  = ∫ x, conj (f x) * g x ∂μ :=
begin
  apply integral_congr_ae,
  have hf_ae := f.coe_fn_to_Lp μ,
  have hg_ae := g.coe_fn_to_Lp μ,
  filter_upwards [hf_ae, hg_ae] with _ hf hg,
  rw [hf, hg],
  simp
end

end inner_continuous

end measure_theory


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

Computational realization of topological spaces (experimental).
-/
import topology.bases
import data.analysis.filter
open set
open filter (hiding realizer)
open_locale topological_space

/-- A `ctop α σ` is a realization of a topology (basis) on `α`,
  represented by a type `σ` together with operations for the top element and
  the intersection operation. -/
structure ctop (α σ : Type*) :=
(f : σ → set α)
(top : α → σ)
(top_mem : ∀ x : α, x ∈ f (top x))
(inter : Π a b (x : α), x ∈ f a ∩ f b → σ)
(inter_mem : ∀ a b x h, x ∈ f (inter a b x h))
(inter_sub : ∀ a b x h, f (inter a b x h) ⊆ f a ∩ f b)

variables {α : Type*} {β : Type*} {σ : Type*} {τ : Type*}

namespace ctop
section
variables (F : ctop α σ)

instance : has_coe_to_fun (ctop α σ) := ⟨_, ctop.f⟩

@[simp] theorem coe_mk (f T h₁ I h₂ h₃ a) : (@ctop.mk α σ f T h₁ I h₂ h₃) a = f a := rfl

/-- Map a ctop to an equivalent representation type. -/
def of_equiv (E : σ ≃ τ) : ctop α σ → ctop α τ
| ⟨f, T, h₁, I, h₂, h₃⟩ :=
  { f         := λ a, f (E.symm a),
    top       := λ x, E (T x),
    top_mem   := λ x, by simpa using h₁ x,
    inter     := λ a b x h, E (I (E.symm a) (E.symm b) x h),
    inter_mem := λ a b x h, by simpa using h₂ (E.symm a) (E.symm b) x h,
    inter_sub := λ a b x h, by simpa using h₃ (E.symm a) (E.symm b) x h }

@[simp] theorem of_equiv_val (E : σ ≃ τ) (F : ctop α σ) (a : τ) :
  F.of_equiv E a = F (E.symm a) := by cases F; refl

end

/-- Every `ctop` is a topological space. -/
def to_topsp (F : ctop α σ) : topological_space α :=
topological_space.generate_from (set.range F.f)

theorem to_topsp_is_topological_basis (F : ctop α σ) :
  @topological_space.is_topological_basis _ F.to_topsp (set.range F.f) :=
by letI := F.to_topsp; exact
⟨λ u ⟨a, e₁⟩ v ⟨b, e₂⟩, e₁ ▸ e₂ ▸
   λ x h, ⟨_, ⟨_, rfl⟩, F.inter_mem a b x h, F.inter_sub a b x h⟩,
eq_univ_iff_forall.2 $ λ x, ⟨_, ⟨_, rfl⟩, F.top_mem x⟩, rfl⟩

@[simp] theorem mem_nhds_to_topsp (F : ctop α σ) {s : set α} {a : α} :
  s ∈ @nhds _ F.to_topsp a ↔ ∃ b, a ∈ F b ∧ F b ⊆ s :=
(@topological_space.is_topological_basis.mem_nhds_iff
  _ F.to_topsp _ _ _ F.to_topsp_is_topological_basis).trans $
⟨λ ⟨_, ⟨x, rfl⟩, h⟩, ⟨x, h⟩, λ ⟨x, h⟩, ⟨_, ⟨x, rfl⟩, h⟩⟩

end ctop

/-- A `ctop` realizer for the topological space `T` is a `ctop`
  which generates `T`. -/
structure ctop.realizer (α) [T : topological_space α] :=
(σ : Type*)
(F : ctop α σ)
(eq : F.to_topsp = T)
open ctop

protected def ctop.to_realizer (F : ctop α σ) : @ctop.realizer _ F.to_topsp :=
@ctop.realizer.mk _ F.to_topsp σ F rfl

namespace ctop.realizer

protected theorem is_basis [T : topological_space α] (F : realizer α) :
  topological_space.is_topological_basis (set.range F.F.f) :=
by have := to_topsp_is_topological_basis F.F; rwa F.eq at this

protected theorem mem_nhds [T : topological_space α] (F : realizer α) {s : set α} {a : α} :
  s ∈ 𝓝 a ↔ ∃ b, a ∈ F.F b ∧ F.F b ⊆ s :=
by have := mem_nhds_to_topsp F.F; rwa F.eq at this

theorem is_open_iff [topological_space α] (F : realizer α) {s : set α} :
  is_open s ↔ ∀ a ∈ s, ∃ b, a ∈ F.F b ∧ F.F b ⊆ s :=
is_open_iff_mem_nhds.trans $ ball_congr $ λ a h, F.mem_nhds

theorem is_closed_iff [topological_space α] (F : realizer α) {s : set α} :
  is_closed s ↔ ∀ a, (∀ b, a ∈ F.F b → ∃ z, z ∈ F.F b ∩ s) → a ∈ s :=
is_open_compl_iff.symm.trans $ F.is_open_iff.trans $ forall_congr $ λ a,
show (a ∉ s → (∃ (b : F.σ), a ∈ F.F b ∧ ∀ z ∈ F.F b, z ∉ s)) ↔ _,
by haveI := classical.prop_decidable; rw [not_imp_comm];
   simp [not_exists, not_and, not_forall, and_comm]

theorem mem_interior_iff [topological_space α] (F : realizer α) {s : set α} {a : α} :
  a ∈ interior s ↔ ∃ b, a ∈ F.F b ∧ F.F b ⊆ s :=
mem_interior_iff_mem_nhds.trans F.mem_nhds

protected theorem is_open [topological_space α] (F : realizer α) (s : F.σ) : is_open (F.F s) :=
is_open_iff_nhds.2 $ λ a m, by simpa using F.mem_nhds.2 ⟨s, m, subset.refl _⟩

theorem ext [T : topological_space α] {σ : Type*} {F : ctop α σ}
  (H₁ : ∀ a, is_open (F a))
  (H₂ : ∀ a s, s ∈ 𝓝 a → ∃ b, a ∈ F b ∧ F b ⊆ s) :
  F.to_topsp = T :=
ext' $ λ a s, ⟨H₂ a s, λ ⟨b, h₁, h₂⟩, mem_nhds_sets_iff.2 ⟨_, h₂, H₁ _, h₁⟩⟩

variable [topological_space α]

protected def id : realizer α := ⟨{x:set α // is_open x},
{ f            := subtype.val,
  top          := λ _, ⟨univ, is_open_univ⟩,
  top_mem      := mem_univ,
  inter        := λ ⟨x, h₁⟩ ⟨y, h₂⟩ a h₃, ⟨_, is_open_inter h₁ h₂⟩,
  inter_mem    := λ ⟨x, h₁⟩ ⟨y, h₂⟩ a, id,
  inter_sub    := λ ⟨x, h₁⟩ ⟨y, h₂⟩ a h₃, subset.refl _ },
ext subtype.property $ λ x s h,
  let ⟨t, h, o, m⟩ := mem_nhds_sets_iff.1 h in ⟨⟨t, o⟩, m, h⟩⟩

def of_equiv (F : realizer α) (E : F.σ ≃ τ) : realizer α :=
⟨τ, F.F.of_equiv E, ext' (λ a s, F.mem_nhds.trans $
 ⟨λ ⟨s, h⟩, ⟨E s, by simpa using h⟩, λ ⟨t, h⟩, ⟨E.symm t, by simpa using h⟩⟩)⟩

@[simp] theorem of_equiv_σ (F : realizer α) (E : F.σ ≃ τ) : (F.of_equiv E).σ = τ := rfl
@[simp] theorem of_equiv_F (F : realizer α) (E : F.σ ≃ τ) (s : τ) :
  (F.of_equiv E).F s = F.F (E.symm s) := by delta of_equiv; simp

protected def nhds (F : realizer α) (a : α) : (𝓝 a).realizer :=
⟨{s : F.σ // a ∈ F.F s},
{ f            := λ s, F.F s.1,
  pt           := ⟨_, F.F.top_mem a⟩,
  inf          := λ ⟨x, h₁⟩ ⟨y, h₂⟩, ⟨_, F.F.inter_mem x y a ⟨h₁, h₂⟩⟩,
  inf_le_left  := λ ⟨x, h₁⟩ ⟨y, h₂⟩ z h, (F.F.inter_sub x y a ⟨h₁, h₂⟩ h).1,
  inf_le_right := λ ⟨x, h₁⟩ ⟨y, h₂⟩ z h, (F.F.inter_sub x y a ⟨h₁, h₂⟩ h).2 },
filter_eq $ set.ext $ λ x,
⟨λ ⟨⟨s, as⟩, h⟩, mem_nhds_sets_iff.2 ⟨_, h, F.is_open _, as⟩,
 λ h, let ⟨s, h, as⟩ := F.mem_nhds.1 h in ⟨⟨s, h⟩, as⟩⟩⟩

@[simp] theorem nhds_σ (m : α → β) (F : realizer α) (a : α) :
  (F.nhds a).σ = {s : F.σ // a ∈ F.F s} := rfl
@[simp] theorem nhds_F (m : α → β) (F : realizer α) (a : α) (s) :
  (F.nhds a).F s = F.F s.1 := rfl

theorem tendsto_nhds_iff {m : β → α} {f : filter β} (F : f.realizer) (R : realizer α) {a : α} :
  tendsto m f (𝓝 a) ↔ ∀ t, a ∈ R.F t → ∃ s, ∀ x ∈ F.F s, m x ∈ R.F t :=
(F.tendsto_iff _ (R.nhds a)).trans subtype.forall

end ctop.realizer

structure locally_finite.realizer [topological_space α] (F : realizer α) (f : β → set α) :=
(bas : ∀ a, {s // a ∈ F.F s})
(sets : ∀ x:α, fintype {i | (f i ∩ F.F (bas x)).nonempty})

theorem locally_finite.realizer.to_locally_finite [topological_space α]
  {F : realizer α} {f : β → set α} (R : locally_finite.realizer F f) :
  locally_finite f :=
λ a, ⟨_, F.mem_nhds.2
  ⟨(R.bas a).1, (R.bas a).2, subset.refl _⟩, ⟨R.sets a⟩⟩

theorem locally_finite_iff_exists_realizer [topological_space α]
  (F : realizer α) {f : β → set α} : locally_finite f ↔ nonempty (locally_finite.realizer F f) :=
⟨λ h, let ⟨g, h₁⟩ := classical.axiom_of_choice h,
    ⟨g₂, h₂⟩ := classical.axiom_of_choice (λ x,
       show ∃ (b : F.σ), x ∈ (F.F) b ∧ (F.F) b ⊆ g x, from
       let ⟨h, h'⟩ := h₁ x in F.mem_nhds.1 h) in
  ⟨⟨λ x, ⟨g₂ x, (h₂ x).1⟩, λ x, finite.fintype $
    let ⟨h, h'⟩ := h₁ x in h'.subset $ λ i hi,
    hi.mono (inter_subset_inter_right _ (h₂ x).2)⟩⟩,
 λ ⟨R⟩, R.to_locally_finite⟩

def compact.realizer [topological_space α] (R : realizer α) (s : set α) :=
∀ {f : filter α} (F : f.realizer) (x : F.σ), f ≠ ⊥ →
  F.F x ⊆ s → {a // a∈s ∧ 𝓝 a ⊓ f ≠ ⊥}


inductive Foo : Nat -> Type  where
| mk (a b : Nat) : Foo a -> Foo b

#check @Foo.mk
example : (a b : Nat) → Foo a → Foo b := @Foo.mk

#print Foo

namespace Ex2

def natToType : Nat → Type
| 0 => Unit
| _ => Bool

inductive Foo : Nat → Char → Prop
| mk (n : Nat) (elem : natToType n) (c : Char) : Foo n c

#print Foo

end Ex2


class Foo (α : Type) where
  decEq : DecidableEq α

instance instDecidableEq {α} [Foo α] : DecidableEq α := Foo.decEq
instance instFooNat : Foo Nat := ⟨by infer_instance⟩

def kron (i j : α) [DecidableEq α] : Nat := if (i=j) then 1 else 0

theorem kron_right_mul (α : Type) [foo : Foo α]  (i j : α) (x : Nat) : x * kron i j = kron i j * x := sorry

example {i j : Nat} : i * kron i j = kron i j * i := by
  rw [kron_right_mul]


import analysis.inner_product_space.pi_L2
import linear_algebra.affine_space.midpoint
import geometry.euclidean.basic
import geometry.euclidean.triangle

/-
Bulgarian Mathematical Olympiad 1998, Problem 2

A convex quadrilateral ABCD has AD = CD and ∠DAB = ∠ABC < 90°.
The line through D and the midpoint of BC intersects line AB
in point E. Prove that ∠BEC = ∠DAC. (Note: The problem is valid
without the assumption ∠ABC < 90°.)

-/

open_locale euclidean_geometry

theorem bulgaria1998_q2
    (A B C D E M: euclidean_space ℝ (fin 2))
    (H1 : dist D A = dist D C)
    (H2 : ∠ D A B = ∠ A B C)
    (H3 : M = midpoint ℝ B C) :
    ∠ B E C = ∠ D A C :=
begin
  let x := ∠ D A C,
  have : ∠ D A C = ∠ D C A := euclidean_geometry.angle_eq_angle_of_dist_eq H1,
  let y := ∠ C A B,
  have : ∠ A B C = x + y,
  {
    rw ← H2,
    sorry, -- hm... might need the acuteness assumption, actually.
  },
  sorry
end


/-
Author: <Redacted for anonymized submission>
-/
-- import snarks.groth16.declarations
import ...attributes
import ...integral_domain_tactic
import ...general_lemmas.polynomial_degree
import data.mv_polynomial.basic
import data.mv_polynomial.funext
import data.polynomial.field_division
import algebra.polynomial.big_operators
-- import ...attributes
import .vars

/-!
# Knowledge Soundness

This file proves the knowledge-soundness property of the Groth16 system for type III pairings, as
presented in "Another Look at Extraction and Randomization of Groth’s zk-SNARK" by
[Baghery et al.](https://eprint.iacr.org/2020/811.pdf).

-/

open_locale big_operators classical

section groth16

-- TODO we open mv_polynomial, so we should be able to delete a lot of `mv_polynomial.`
open mv_polynomial groth16

noncomputable theory

universes u

/-- The finite field parameter of our SNARK -/
parameter {F : Type u}
parameter [field F]

/-- The naturals representing:
  n_stmt - the statement size,
  n_wit - the witness size -/
parameters {n_stmt n_wit n_var : ℕ}

/-- u_stmt and u_wit are fin-indexed collections of polynomials from the square span program -/
parameter {u_stmt : fin n_stmt → (polynomial F) }
parameter {u_wit : fin n_wit → (polynomial F) }
parameter {v_stmt : fin n_stmt → (polynomial F) }
parameter {v_wit : fin n_wit → (polynomial F) }
parameter {w_stmt : fin n_stmt → (polynomial F) }
parameter {w_wit : fin n_wit → (polynomial F) }

/-- The roots of the polynomial t -/
parameter {r : fin n_wit → F}
/-- t is the polynomial divisibility by which is used to verify satisfaction of the SSP -/
def t : polynomial F := ∏ i in (finset.univ : finset (fin n_wit)), (polynomial.X - polynomial.C (r i))
-- TODO this could potentially be spun off into a mathlib definition

/-- Checks whether a statement witness pair satisfies the SSP -/
def satisfying (a_stmt : fin n_stmt → F ) (a_wit : fin n_wit → F) :=
((∑ i in (finset.univ : finset (fin n_stmt)), a_stmt i • u_stmt i
  + (∑ i in (finset.univ : finset (fin n_wit)), a_wit i • u_wit i))
  *
(∑ i in (finset.univ : finset (fin n_stmt)), a_stmt i • v_stmt i
  + (∑ i in (finset.univ : finset (fin n_wit)), a_wit i • v_wit i))
  -
(∑ i in (finset.univ : finset (fin n_stmt)), a_stmt i • w_stmt i
  + (∑ i in (finset.univ : finset (fin n_wit)), a_wit i • w_wit i)))
   %ₘ t = 0

run_cmd mk_simp_attr `crs
run_cmd tactic.add_doc_string `simp_attr.crs "Attribute for defintions of CRS elements"

/-- The CRS elements
These funtions are actually multivariate Laurent polynomials of the toxic waste samples,
but we represent them here as functions on assignments of the variables to values.
-/
@[crs]
def crs_α  (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.α)
@[crs]
def crs_β (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.β)
@[crs]
def crs_γ (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.γ)
@[crs]
def crs_δ (f : groth16.vars → F) : polynomial F := polynomial.C (f vars.δ)
@[crs]
def crs_powers_of_x (i : fin n_var) (f : groth16.vars → F) : polynomial F := ((polynomial.X)^(i : ℕ))
@[crs]
def crs_l (i : fin n_stmt) (f : groth16.vars → F) : polynomial F :=
polynomial.C (1 / f vars.γ) * (polynomial.C (f vars.β / f vars.γ) * u_stmt i
+
polynomial.C  (f vars.α / f vars.γ) * v_stmt i
+
(w_stmt i))
@[crs]
def crs_m (i : fin n_wit) (f : groth16.vars → F) : polynomial F :=
polynomial.C (1 / f vars.δ) * (polynomial.C  (f vars.β / f vars.δ) * (u_wit i)
+
polynomial.C  (f vars.α / f vars.δ) * (v_wit i)
+
(w_wit i))
@[crs]
def crs_n (i : fin (n_var - 1)) (f : groth16.vars → F) : polynomial F :=
(polynomial.X)^(i : ℕ) * t * polynomial.C (1 / f vars.δ)

/-- The coefficients of the CRS elements in the algebraic adversary's representation -/
parameters {A_α A_β A_γ A_δ B_α B_β B_γ B_δ C_α C_β C_γ C_δ  : F}
parameters {A_x B_x C_x : fin n_var → F}
parameters {A_l B_l C_l : fin n_stmt → F}
parameters {A_m B_m C_m : fin n_wit → F}
parameters {A_h B_h C_h : fin (n_var-1) → F}

/-- Polynomial forms of the adversary's proof representation -/
def A (f : groth16.vars → F) : polynomial F :=
  polynomial.C A_α * (crs_α f)
  +
  polynomial.C A_β * (crs_β f)
  +
  polynomial.C A_δ * crs_δ f
  +
  ∑ i in ((finset.univ : finset (fin n_var))), polynomial.C (A_x i) * (crs_powers_of_x i f)
  +
  ∑ i in (finset.univ : finset (fin n_stmt)), polynomial.C (A_l i) * (crs_l i f)
  +
  ∑ i in (finset.univ : finset (fin n_wit)), polynomial.C (A_m i) * (crs_m i f)
  +
  ∑ i in (finset.univ : finset (fin (n_var-1))), polynomial.C (A_h i) * (crs_n i f)

def B (f : groth16.vars → F) : polynomial F  :=
  polynomial.C B_β * crs_β f
  +
  polynomial.C B_γ * crs_γ f
  +
  polynomial.C B_δ * crs_δ f
  +
  ∑ i in ((finset.univ : finset (fin n_var))), polynomial.C (B_x i) * (crs_powers_of_x i f)

def C (f : groth16.vars → F) : polynomial F  :=
  polynomial.C C_α * crs_α f
  +
  polynomial.C C_β * crs_β f
  +
  polynomial.C C_δ * crs_δ f
  +
  ∑ i in ((finset.univ : finset (fin n_var))), polynomial.C (C_x i) * (crs_powers_of_x i f)
  +
  ∑ i in (finset.univ : finset (fin n_stmt)), polynomial.C (C_l i) * (crs_l i f)
  +
  ∑ i in (finset.univ : finset (fin n_wit)), polynomial.C (C_m i) * (crs_m i f)
  +
  ∑ i in (finset.univ : finset (fin (n_var-1))), polynomial.C (C_h i) * (crs_n i f)

local notation `groth16polynomial` := mv_polynomial vars (polynomial F)

/-- The modified CRS elements
these are multivariate (non-Laurent!) polynomials of the toxic waste samples,
obtained by multiplying the Laurent polynomial forms of the CRS through by γ * δ.
We will later prove that the laurent polynomial equation is equivalent to a similar equation of the modified crs elements, allowing us to construct a proof in terms of polynomials -/
@[crs]
def crs'_α  : groth16polynomial := X vars.α * X vars.γ * X vars.δ
@[crs]
def crs'_β : groth16polynomial := X vars.β * X vars.γ * X vars.δ
@[crs]
def crs'_γ : groth16polynomial := X vars.γ * X vars.γ * X vars.δ
@[crs]
def crs'_δ : groth16polynomial := X vars.δ * X vars.γ * X vars.δ
@[crs]
def crs'_powers_of_x (i : fin n_var) : (groth16polynomial) := mv_polynomial.C (polynomial.X ^ (i : ℕ)) * X vars.γ * X vars.δ
@[crs]
def crs'_l (i : fin n_stmt) : (groth16polynomial) :=
(X vars.β * X vars.δ) * mv_polynomial.C (u_stmt i)
+
(X vars.α * X vars.δ) * mv_polynomial.C (v_stmt i)
+
X vars.δ * mv_polynomial.C (w_stmt i)
@[crs]
def crs'_m (i : fin n_wit) : (groth16polynomial) :=
(X vars.β * X vars.γ) * mv_polynomial.C (u_wit i)
+
(X vars.α * X vars.γ) * mv_polynomial.C (v_wit i)
+
X vars.γ * mv_polynomial.C (w_wit i)
@[crs]
def crs'_t (i : fin (n_var - 1)) : (groth16polynomial) :=
X vars.γ * mv_polynomial.C ((polynomial.X)^(i : ℕ) * t)

/-- Polynomial form of A in the adversary's proof representation -/
def A'  : groth16polynomial :=
  crs'_α * mv_polynomial.C (polynomial.C (A_α))
  +
  crs'_β * mv_polynomial.C (polynomial.C (A_β))
  +
  crs'_δ * mv_polynomial.C (polynomial.C (A_δ))
  +
  X vars.γ * X vars.δ * mv_polynomial.C ∑ i in ((finset.univ : finset (fin n_var))), (polynomial.C (A_x i) * polynomial.X ^ (i : ℕ))
  +
  ∑ i in (finset.univ : finset (fin n_stmt)), (crs'_l i) * mv_polynomial.C (polynomial.C (A_l i))
  +
  ∑ i in (finset.univ : finset (fin n_wit)), (crs'_m i) * mv_polynomial.C (polynomial.C (A_m i))
  +
  ∑ i in (finset.univ : finset (fin (n_var-1))), (crs'_t i) * mv_polynomial.C (polynomial.C (A_h i))

/-- Polynomial form of B in the adversary's proof representation -/
def B'  : groth16polynomial :=
  crs'_β * mv_polynomial.C (polynomial.C (B_β))
  +
  crs'_γ * mv_polynomial.C (polynomial.C (B_γ))
  +
  crs'_δ * mv_polynomial.C (polynomial.C (B_δ))
  +
  X vars.γ * X vars.δ * mv_polynomial.C ∑ i in ((finset.univ : finset (fin n_var))), (polynomial.C (B_x i) * polynomial.X ^ (i : ℕ))

/-- Polynomial form of C in the adversary's proof representation -/
def C'  : groth16polynomial :=
  crs'_α * mv_polynomial.C (polynomial.C (C_α))
  +
  crs'_β * mv_polynomial.C (polynomial.C (C_β))
  +
  crs'_δ * mv_polynomial.C (polynomial.C (C_δ))
  +
  X vars.γ * X vars.δ * mv_polynomial.C ∑ i in ((finset.univ : finset (fin n_var))), (polynomial.C (C_x i) * polynomial.X ^ (i : ℕ))
  +
  ∑ i in (finset.univ : finset (fin n_stmt)), (crs'_l i) * mv_polynomial.C (polynomial.C (C_l i))
  +
  ∑ i in (finset.univ : finset (fin n_wit)), (crs'_m i) * mv_polynomial.C (polynomial.C (C_m i))
  +
  ∑ i in (finset.univ : finset (fin (n_var-1))), (crs'_t i) * mv_polynomial.C (polynomial.C (C_h i))

def verified (a_stmt : fin n_stmt → F ) : Prop := A * B = crs_α * crs_β + (∑ i in (finset.univ : finset (fin n_stmt)), a_stmt i • crs_l i ) * crs_γ + C * crs_δ

def verified' (a_stmt : fin n_stmt → F ) : Prop := A' * B' = crs'_α * crs'_β + (∑ i in (finset.univ : finset (fin n_stmt)), mv_polynomial.C (polynomial.C (a_stmt i)) * crs'_l i ) * crs'_γ + C' * crs'_δ

-- TODO use this for lots of profiling data
-- set_option profiler true

/--
This lemma proves that the verification procedure succeeding on the unmodified (Laurent) CRS
elements implies that it succeeds with the modified (mv_polynomial) CRS elements. This lets us put
our hypotheses in terms of mv_polynomial equations.
-/
lemma modification_equivalence (a_stmt : fin n_stmt → F ) :
  verified a_stmt -> verified' a_stmt
:=
begin
  -- TODO a few conditions likely still need to be added, such as degree bounds and the values
  -- being nonzero.
  sorry,
  -- rw verified,
  -- rw verified',
  -- intro h,
  -- rw function.funext_iff at h,
  -- -- Apply functional extensionality
  -- simp [A, B, C] at h,

  -- rw mv_polynomial.funext_iff,
  -- intro vars_evaluation,
  -- simp [A', B', C'] with crs,
  -- -- apply polynomial.funext, -- TODO prove a version of this lemma for degree bounded polynomials on non infinite fields.
  -- -- intro x_evaluation,
  -- -- simp,
  -- -- simp [A', B', C'],
  -- -- simp with crs,

  -- have h2 := h vars_evaluation,
  -- done,

end

open finsupp

lemma A_α_mul (p : polynomial F) : p * polynomial.C A_α  = polynomial.C A_α * p := by ring

lemma B_β_mul (p : polynomial F) : p * polynomial.C B_β  = polynomial.C B_β * p := by ring

-- TODO Add to Mathlib next to C_eq_zero
@[simp] lemma polynomial.C_eq_one (a : F) : polynomial.C a = 1 ↔ a = 1 :=
calc polynomial.C a = 1 ↔ polynomial.C a = polynomial.C 1 : by rw polynomial.C_1
         ... ↔ a = 1 : polynomial.C_inj

lemma simplifier1 (x : fin n_stmt) (a_stmt : fin n_stmt → F )
  : polynomial.C (a_stmt x) * u_stmt x = u_stmt x * polynomial.C (a_stmt x)
  :=
  by ring

lemma simplifier2 (x : fin n_stmt) (a_stmt : fin n_stmt → F )
  : polynomial.C (a_stmt x) * v_stmt x = v_stmt x * polynomial.C (a_stmt x)
  :=
  by ring

lemma polynomial.mul_mod_by_monic (t p : polynomial F) (mt : t.monic) : (t * p) %ₘ t = 0 :=
begin
  rw polynomial.dvd_iff_mod_by_monic_eq_zero,
  apply dvd_mul_right,
  exact mt,
end

set_option trace.simp_lemmas true

/-- The main theorem for the soundness of the Groth '16 SNARK.
This shows that if the adversary polynomials obey the equations that the verification suggests,
then the C_m coefficients give a satisfying witness. -/
theorem soundness (a_stmt : fin n_stmt → F ) :
  verified a_stmt
  -> (satisfying a_stmt C_m)
:=
begin

  intros eqn,
  rw satisfying,
  simp only [polynomial.smul_eq_C_mul, rearrange_constants_right_hard],
  suffices :
    (∑ (i : fin n_stmt) in finset.univ, u_stmt i * polynomial.C (a_stmt i) + ∑ (i : fin n_wit) in finset.univ, u_wit i * polynomial.C (C_m i))
    *
    (∑ (i : fin n_stmt) in finset.univ, v_stmt i * polynomial.C (a_stmt i) + ∑ (i : fin n_wit) in finset.univ, v_wit i * polynomial.C (C_m i))
    =
    (∑ (i : fin n_stmt) in finset.univ, w_stmt i * polynomial.C (a_stmt i) + ∑ (i : fin n_wit) in finset.univ, w_wit i * polynomial.C (C_m i))
    +
    ∑ (x : fin (n_var - 1)) in finset.univ, polynomial.X ^ (x : ℕ) * t * polynomial.C (C_h x),
  {
    rw <-sub_eq_iff_eq_add' at this,
    have h := congr_arg (%ₘ t) this,
    simp only at h,
    rw h,
    clear this h,
    conv
    begin
      to_lhs,
      congr,
      congr,
      skip,
      funext,
      rw mul_comm,
      rw <-mul_assoc,
      skip,
    end,
    rw <-finset.sum_mul,
    rw mul_comm,
    apply polynomial.mul_mod_by_monic,
    rw t,
    apply monic_of_product_form,
  },

  -- Step 0: Modify the hypothesis to be an equation of mv_polynomials
  have eqn' := modification_equivalence a_stmt (eqn),
  -- done,

  -- Step 1: Obtain the coefficient equations of the mv_polynomials

  rw verified' at eqn',
  rw [A', B', C'] at eqn',
  simp only [] with crs at eqn',
  -- simp only [mv_polynomial.X, C_apply, mv_polynomial.monomial_mul, one_mul, mul_one, add_zero, zero_add, finset.sum_add_distrib, finset.sum_hom, mul_add, add_mul, sum_monomial_hom] at eqn',

  have h0012 := congr_arg (coeff (single vars.α 0 + single vars.β 0 + single vars.γ 1 + single vars.δ 2)) eqn',
  have h0021 := congr_arg (coeff (single vars.α 0 + single vars.β 0 + single vars.γ 2 + single vars.δ 1)) eqn',
  have h0022 := congr_arg (coeff (single vars.α 0 + single vars.β 0 + single vars.γ 2 + single vars.δ 2)) eqn',
  have h0112 := congr_arg (coeff (single vars.α 0 + single vars.β 1 + single vars.γ 1 + single vars.δ 2)) eqn',
  have h0121 := congr_arg (coeff (single vars.α 0 + single vars.β 1 + single vars.γ 2 + single vars.δ 1)) eqn',
  have h0122 := congr_arg (coeff (single vars.α 0 + single vars.β 1 + single vars.γ 2 + single vars.δ 2)) eqn',
  have h0212 := congr_arg (coeff (single vars.α 0 + single vars.β 2 + single vars.γ 1 + single vars.δ 2)) eqn',
  have h0221 := congr_arg (coeff (single vars.α 0 + single vars.β 2 + single vars.γ 2 + single vars.δ 1)) eqn',
  have h0222 := congr_arg (coeff (single vars.α 0 + single vars.β 2 + single vars.γ 2 + single vars.δ 2)) eqn',
  have h1022 := congr_arg (coeff (single vars.α 1 + single vars.β 0 + single vars.γ 2 + single vars.δ 2)) eqn',
  -- have h1023 := congr_arg (coeff (single vars.α 1 + single vars.β 0 + single vars.γ 2 + single vars.δ 3)) eqn', -- not needed
  have h1112 := congr_arg (coeff (single vars.α 1 + single vars.β 1 + single vars.γ 1 + single vars.δ 2)) eqn',
  have h1121 := congr_arg (coeff (single vars.α 1 + single vars.β 1 + single vars.γ 2 + single vars.δ 1)) eqn',
  have h1122 := congr_arg (coeff (single vars.α 1 + single vars.β 1 + single vars.γ 2 + single vars.δ 2)) eqn',

  clear eqn eqn',

  simp only [finsupp_vars_eq_ext] with coeff_simp finsupp_eq at h0012 h0021 h0022 h0112 h0121 h0122 h0212 h0221 h0222 h1022 h1112 h1121 h1122,
  simp only [] with finsupp_simp at h0012 h0021 h0022 h0112 h0121 h0122 h0212 h0221 h0222 h1022 h1112 h1121 h1122,

  -- Step 2: Recursively simplify and case-analyze the equations

  trace "Moving Cs right",
  simp only [simplifier1, simplifier2] at *,

  trace "Grouping distributivity",
  simp only [<-mul_add, <-add_mul, <-add_assoc, add_mul_distrib, add_mul_distrib'] at *,

  -- done,

  trace "Main simplification",
  simp only [*] with integral_domain_simp at *,
  tactic.integral_domain_tactic_v4,

  -- done,

  -- Solve remaining cases by hand
  { rw [<-h1022, <-h0122, <-h0022],
    simp only [B_β_mul],
    simp only [<-mul_assoc],
    simp only [A_α_mul],
    simp only [<-mul_assoc],
    rw h1122,
    ring, },

end

end groth16


import tactic.to_int

example (a b c d : ℕ)
  (h : a + b ≥ c)
  (h₀ : a ∣ c)
  (h' : a + c + 17 ≥ d)
  (sol : a * c ≤ b + d * c) :
  a * c ≤ b + d * c :=
begin
  to_int,
    -- a : ℤ,
    -- a_nneg : a ≥ 0,
    -- b : ℤ,
    -- b_nneg : b ≥ 0,
    -- c : ℤ,
    -- c_nneg : c ≥ 0,
    -- d : ℤ,
    -- d_nneg : d ≥ 0,
    -- h : a + b ≥ c,
    -- h₀ : a ∣ c,
    -- h' : a + c + 17 ≥ d
    -- ⊢ a * c ≤ b + d * c
  guard_hyp a := ℤ,
  guard_hyp b := ℤ,
  guard_hyp c := ℤ,
  guard_hyp d := ℤ,
  guard_hyp h := a + b ≥ c,
  guard_target a * c ≤ b + d * c,
  exact sol
end


/-
Copyright (c) 2021 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang
-/
import algebra.category.CommRing
import algebra.category.Module.basic
import linear_algebra.tensor_product

open_locale tensor_product

namespace change_of_rings

namespace restriction_of_scalars

universe u

variables {R S : CommRing.{u}} -- [ring R] [ring S] -- (f : R →+* S)
variable (f : R ⟶ S)
variables (N : Module S) -- [add_comm_monoid N] [module S N]
include f

@[reducible] def module :
  Module R :=
{ carrier := N,
  is_module := module.comp_hom _ f, }.
localized "notation f `^*` N := restriction_of_scalars.module f N" in change_of_rings

def is_module : _root_.module R N := (f ^* N).is_module

localized "attribute [instance] restriction_of_scalars.is_module" in change_of_rings

instance has_scalar' : _root_.has_scalar S (f ^* N) :=
{ smul := λ s n, @has_scalar.smul S N _ s n }.

@[simp] lemma smul_def' (r : R) (n : f ^* N) : r • n = f r • n := rfl
@[simp] lemma smul_def (r : R) (n : N) :
  @has_scalar.smul R N begin
    haveI := is_module f N,
    apply_instance,
  end r n = f r • n := rfl

def compatible_smul (N₁ N₂ : Module S) :
  let m1 := is_module f N₁,
      m2 := is_module f N₂,
      m3 := is_module f ⟨S⟩ in
  begin
    resetI,
    exact linear_map.compatible_smul N₁ N₂ R S
  end :=
let m1 := is_module f N₁,
    m2 := is_module f N₂,
    m3 := is_module f ⟨S⟩ in
begin
  resetI,
  fconstructor,
  intros g r n,
  calc  g (r • n)
      = g (f r • n) : by congr' 1
    ... = f r • g n : by { erw linear_map.map_smul, },
end
/--restriction of scalar is a functor from `S`-modules to `R`-modules.-/
def functor : Module S ⥤ Module R :=
{ obj := λ N, f ^* N,
  map := λ N₁ N₂ l,
  let m1 := is_module f N₁,
      m2 := is_module f N₂,
      m3 := is_module f ⟨S⟩,
      m4 := compatible_smul f N₁ N₂ in
  begin
    dsimp only at m4,
    resetI,
    exact linear_map.restrict_scalars R l,
  end }.

localized "notation f `⥤^*` M := (restriction_of_scalars.functor f).obj M" in change_of_rings

end restriction_of_scalars

namespace extension_of_scalars

open category_theory tensor_product

universe u

variables {R S : CommRing.{u}} (f : R ⟶ S) (M : Module R)
include f

-- /--
-- This action gives `S` an `R`-module strucutre
-- -/
-- def is_R_mod_S : module R S := restriction_of_scalars.is_module ⟨S⟩ f

-- localized "attribute [instance] extension_of_scalars.is_R_mod_S" in change_of_rings

-- @[simp] lemma smul_def (r : R) (s : S) :
--   @has_scalar.smul _ _ begin
--     haveI := is_R_mod_S f,
--     resetI,
--     apply_instance
--   end r s = f r * s := rfl

include M
localized "notation M `⊗[` R `,` f `]` S := @tensor_product R _ M S _ _ _
  (restriction_of_scalars.is_module f ⟨S⟩)" in change_of_rings
localized "notation m `⊗ₜ[` R `,` f `]` s := @tensor_product.tmul R _ _ _ _ _ _
  (restriction_of_scalars.is_module f ⟨_⟩) m s" in change_of_rings

def smul_by (s : S) : (M ⊗[R, f] S) ⟶ (M ⊗[R, f] S) :=
let m : module R S := restriction_of_scalars.is_module f ⟨S⟩ in
begin
  resetI,
  refine tensor_product.lift _,
  refine ⟨_, _, _⟩,
  { -- we define `m ↦ (s' ↦ m ⊗ (s * s'))`
    refine λ m, ⟨λ s', m ⊗ₜ[R, f] (s * s'), _, _⟩,
    { -- map_add
      intros,
      erw [mul_add, tmul_add], },
    { -- map_smul
      intros,
      rw [ring_hom.id_apply, smul_tmul', smul_tmul],
      congr' 1,
      rw [restriction_of_scalars.smul_def f ⟨S⟩, smul_eq_mul, ← mul_assoc, mul_comm s,
        mul_assoc, restriction_of_scalars.smul_def f ⟨S⟩, smul_eq_mul],
    }, },
  { intros,
    ext,
    simp only [linear_map.coe_mk, map_add, add_tmul],
    refl, },
  { intros,
    ext,
    simp only [linear_map.coe_mk, ring_hom.id_apply, linear_map.smul_apply],
    rw [tensor_product.smul_tmul'], }
end.

lemma smul_by.pure_tensor (s s' : S) (m : M) :
  (smul_by f M s (m ⊗ₜ[R, f] s')) =
  m ⊗ₜ[R, f] (s * s') :=
begin
  simp only [smul_by, tensor_product.lift.tmul, linear_map.coe_mk],
end

lemma smul_by.one : smul_by f M 1 = 𝟙 _ :=
begin
  ext,
  induction x using tensor_product.induction_on with _ _ _ _ ih1 ih2,
  { simpa only [smul_by, map_zero], },
  { simpa only [smul_by.pure_tensor, one_mul], },
  { simp only [category_theory.types_id_apply] at ih1 ih2 ⊢,
    conv_rhs { rw [← ih1, ← ih2] },
    convert map_add _ _ _, },
end.

lemma smul_by.mul (s s' : S) : smul_by f M (s * s') = smul_by f M s' ≫ smul_by f M s :=
begin
  ext,
  induction x using tensor_product.induction_on with _ _ x y ih1 ih2,
  { simp only [smul_by, map_zero, types_comp_apply], },
  { simp [smul_by, mul_assoc], },
  { convert congr_arg2 (+) ih1 ih2 using 1,
    { convert map_add _ _ _ },
    { simp only [types_comp_apply],
      calc  smul_by f M s (smul_by f M s' (x + y))
          = smul_by f M s (smul_by f M s' x + smul_by f M s' y)
          : by { congr' 1, convert map_add _ _ _}
      ... = smul_by f M s (smul_by f M s' x) + smul_by f M s (smul_by f M s' y)
          : by convert map_add _ _ _, }, }
end.

lemma smul_by.apply_zero (s : S) : smul_by f M s 0 = 0 :=
by simp only [smul_by, map_zero]

lemma smul_by.apply_add (s : S) (a b) : smul_by f M s (a + b) = smul_by f M s a + smul_by f M s b :=
by simp [smul_by, map_add]

lemma smul_by.add (s s') : smul_by f M (s + s') = smul_by f M s + smul_by f M s' :=
begin
  ext x,
  induction x using tensor_product.induction_on with _ _ x y ih1 ih2,
  { simp [smul_by], },
  { simp [smul_by, add_mul, tmul_add], },
  { simp only [pi.add_apply, smul_by.apply_add, ih1, ih2],
    rw show ∀ (a b c d : M ⊗[R, f] S), a + b + (c + d) = a + c + (b + d), from _,
    intros,
    -- `ring` doesn't work here for some reason
    rw calc a + b + (c + d) = a + (b + (c + d)) : by rw add_assoc
      ... = a + (b + c + d) : by rw add_assoc
      ... = a + (c + b + d) : by rw add_comm b c
      ... = a + (c + (b + d)) : by rw add_assoc
      ... = a + c + (b + d) : by rw add_assoc, }
end.

lemma smul_by.zero : smul_by f M 0 = 0 :=
begin
  ext,
  induction x using tensor_product.induction_on with _ _ x y ih1 ih2,
  { simp [smul_by], },
  { simp [smul_by], },
  { simp [smul_by.apply_add, ih1, ih2], }
end.

/--
Since `S` has an `R`-module structure, `M ⊗[R] S` can be given an `S`-module structure.
The scalar multiplication is defined by `s • (m ⊗ s') := m ⊗ (s * s')`
-/
@[reducible] def has_scalar_S_M_tensor_S : _root_.has_scalar S (M ⊗[R, f] S) :=
{ smul := λ s', smul_by f M s' }

local attribute [instance] has_scalar_S_M_tensor_S

lemma smul_pure_tensor (s s' : S) (m : M) :
  (s • (m ⊗ₜ[R, f] s')) =
  m ⊗ₜ[R, f] (s * s') :=
by simp only [smul_by, tensor_product.lift.tmul, linear_map.coe_mk]

@[simp] lemma smul_zero (s : S) : s • (0 : M ⊗[R, f] S) = 0 :=
by simp [smul_by]

/--
See above
-/
def mul_action_S_M_tensor_S : _root_.mul_action S (M ⊗[R, f] S) :=
{ one_smul := λ x, begin
    change smul_by _ _ _ _ = _,
    rw smul_by.one f M,
    refl,
  end,
  mul_smul := λ s s' x, begin
    change smul_by _ _ _ _ = smul_by _ _ _ (smul_by _ _ _ _),
    rw smul_by.mul f M,
    refl,
  end,
  ..(has_scalar_S_M_tensor_S f M) }.

localized "attribute [instance] extension_of_scalars.mul_action_S_M_tensor_S" in change_of_rings

def distrib_mul_action_S_M_tensor_S : _root_.distrib_mul_action S (M ⊗[R, f] S) :=
{ smul_zero := λ s, by { change smul_by f M s 0 = 0, apply smul_by.apply_zero, },
  smul_add := λ s x y, begin
    change smul_by f M s (x + y) = smul_by f M s x + smul_by f M s y,
    apply smul_by.apply_add,
  end }

def is_module : module S (M ⊗[R, f] S) :=
{ add_smul := λ s s' x, begin
    change smul_by _ _ _ _ = smul_by _ _ _ _ + smul_by _ _ _ _,
    rw smul_by.add,
    refl,
  end,
  zero_smul := λ x, begin
    change smul_by _ _ _ _ = _,
    rw smul_by.zero,
    refl,
  end,
  ..(distrib_mul_action_S_M_tensor_S f M) }.

def is_module' : module R (M ⊗[R, f] S) :=
infer_instance

-- def compatible_smul (M1 M2 : Module R) :
--   linear_map.compatible_smul (M1 ⊗[R, f] S) (M2 ⊗[R, f] S) S R :=
-- let im1 : module R S := restriction_of_scalars.is_module f ⟨S⟩,
--     im2 : module S (M1 ⊗[R, f] S) := is_module f M1,
--     im3 : module S (M2 ⊗[R, f] S) := is_module f M2 in
-- ⟨λ g s x, begin
--   resetI,
--   induction x using tensor_product.induction_on with m1 s' z1 z2 ih1 ih2,
--   { simp [smul_by.apply_zero], },
--   { simp only [smul_by.pure_tensor],
--     revert s,
--     induction g (m1 ⊗ₜ[R, f] s') using tensor_product.induction_on,
--     rw ← lift.equiv_symm_apply R M1 S (M2 ⊗[R, f] S) g m1 (s * s'),
--     rw ← lift.equiv_symm_apply R M1 S (M2 ⊗[R, f] S) g m1 s',
--     -- dsimp only,
--     -- squeeze_dsimp,
--     -- type_check (tensor_product.lift.equiv R M1 S (M2 ⊗[R, f] S)).symm g m1 s,
--     sorry },
--   { erw [map_add, smul_add s z1 z2, map_add, ih1, ih2, smul_add s (g z1) (g z2)],
--     refl, },
-- end⟩

localized "attribute [instance] extension_of_scalars.is_module extension_of_scalars.is_module'"
  in change_of_rings
/--
See above
-/
def module : Module S :=
{ carrier := M ⊗[R, f] S,
  is_module := is_module f M }

localized "notation f `_*` M := extension_of_scalars.module f M" in change_of_rings

omit M
/--
Extension of scalars is a functor where an `R`-module `M` is sent to `M ⊗ S` and
`l : M1 ⟶ M2` is sent to `m ⊗ s ↦ l m ⊗ s`
-/
def map {M1 M2 : Module R} (l : M1 ⟶ M2) : (f _* M1) ⟶ (f _* M2) :=
let im1 : _root_.module R S := restriction_of_scalars.is_module f ⟨S⟩,
    im2 : _root_.module R (f _* M2) := is_module' f M2 in
begin
  resetI,
  refine
    { to_fun := tensor_product.lift { to_fun := λ m1, _, map_add' := _, map_smul' := _ },
      map_add' := _,
      map_smul' := _ },
  { -- `S ⟶ f _* M2` given by `s ↦ l m ⊗ s`
    refine { to_fun := λ s, (l m1) ⊗ₜ[R, f] s, map_add' := _, map_smul' := _ },
    { -- map_add
      intros,
      rw [tmul_add], },
    { -- map_smul
      intros,
      rw [ring_hom.id_apply, restriction_of_scalars.smul_def f ⟨S⟩ r x, smul_tmul',
        smul_tmul],
      refl, } },
  { intros m m',
    ext s,
    simp [add_tmul], },
  { intros r m,
    ext s,
    simp [smul_tmul], },
  { intros z1 z2,
    simp, },
  { intros s z,
    induction z using tensor_product.induction_on with _ _ z1 z2 ih1 ih2,
    { simp [smul_zero], },
    { simp [smul_pure_tensor], },
    { rw [smul_add, map_add, ring_hom.id_apply, ih1, ih2, map_add, smul_add,
        ring_hom.id_apply], } }
end.

/--
The functor extension of scalars
-/
def functor : Module.{u} R ⥤ Module.{u} S :=
{ obj := λ M, f _* M,
  map := λ M1 M2 l, map f l,
  map_id' := λ M, begin
    ext x,
    rw [map, Module.id_apply],
    induction x using tensor_product.induction_on with _ _ m s ihx ihy,
    { rw map_zero },
    { rw [linear_map.coe_mk, tensor_product.lift.tmul], refl, },
    { rw [linear_map.coe_mk] at ihx ihy ⊢,
      rw [map_add, ihx, ihy], }
  end,
  map_comp' := λ M1 M2 M3 g h, begin
    ext x,
    rw [map, map, map, linear_map.coe_mk, category_theory.comp_apply,
      linear_map.coe_mk, linear_map.coe_mk],
    induction x using tensor_product.induction_on with _ _ m s ihx ihy,
    { rw [map_zero, map_zero, map_zero], },
    { rw [tensor_product.lift.tmul, tensor_product.lift.tmul], refl, },
    { rw [map_add, ihx, ihy, map_add, map_add], }
  end }.

localized "notation f `⥤_*` M := (extension_of_scalars.functor f).obj M" in change_of_rings

end extension_of_scalars

section adjunction

universe u

open category_theory tensor_product
open_locale change_of_rings

variables {R S : CommRing.{u}} (f : R ⟶ S) (X : Module.{u} R) (Y : Module.{u} S)

def backward (g : X ⟶ (f ⥤^* Y)) :
  (f ⥤_* X) ⟶ Y :=
{ to_fun := λ z,
  let m1 := restriction_of_scalars.is_module f ⟨S⟩,
      m2 : module R Y := restriction_of_scalars.is_module f Y,
      m3 : module S (f ⥤^* Y) := Y.is_module in
  begin
    resetI,
    refine tensor_product.lift
      { to_fun := λ x,
          { to_fun := λ s, _,
            map_add' := _,
            map_smul' := _, },
        map_add' := _,
        map_smul' := _ } z,
    { -- `x ⊗ s ↦ s • g x` in Y
      exact s • (g x : Y) },
    { intros, rw add_smul, },
    { intros r s,
      rw [ring_hom.id_apply],
      calc  (r • s) • g x
          = (f r * s) • g x : rfl
      ... = f r • s • g x : by rw [mul_smul], },
    { intros x y,
      ext s,
      simp only [linear_map.coe_mk, smul_add, linear_map.add_apply, map_add], },
    { intros r x,
      ext s,
      simp only [linear_map.coe_mk, ring_hom.id_apply, linear_map.smul_apply,
        linear_map.map_smul],
      erw [← mul_smul, mul_comm, mul_smul],
      refl, },
  end,
  map_add' := λ z1 z2, by simp only [map_add],
  map_smul' := λ r z, begin
    rw [ring_hom.id_apply],
    induction z using tensor_product.induction_on with x y x y ih1 ih2,
    { simp only [smul_zero, map_zero], },
    { erw [extension_of_scalars.smul_pure_tensor],
      simp [tensor_product.lift.tmul, mul_smul], },
    { simp only [smul_add, map_add],
      dsimp only at ih1 ih2,
      rw [ih1, ih2], },
  end }.

def forward (g : (f ⥤_* X) ⟶ Y) :
  X ⟶ (f ⥤^* Y) :=
let m1 : module R S := restriction_of_scalars.is_module f ⟨S⟩,
    m2 : module R Y := restriction_of_scalars.is_module f Y in
{ to_fun := λ x, g (x ⊗ₜ[R, f] 1),
  map_add' := λ x x', by rw [tensor_product.add_tmul, map_add],
  map_smul' := λ r x, begin
    resetI,
    rw [ring_hom.id_apply],
    calc  g ((r • x) ⊗ₜ[R, f] (1 : S))
        = g (x ⊗ₜ[R, f] (r • 1)) : by rw smul_tmul
    ... = g (x ⊗ₜ[R, f] (f r • 1)) : by rw restriction_of_scalars.smul_def f ⟨S⟩
    ... = g (f r • (x ⊗ₜ[R, f] 1)) : by congr' 1
    ... = f r • g (x ⊗ₜ[R, f] 1) : by rw linear_map.map_smul
    ... = r • g (x ⊗ₜ[R, f] 1) : rfl,
  end }.

def equiv :
  ((extension_of_scalars.functor f).obj X ⟶ Y) ≃ (X ⟶ (restriction_of_scalars.functor f).obj Y) :=
{ to_fun := forward f X Y,
  inv_fun := backward f X Y,
  left_inv := λ g, begin
    ext z,
    induction z using tensor_product.induction_on with x s z1 z2 ih1 ih2,
    { simp only [map_zero], },
    { erw tensor_product.lift.tmul,
      simp only [linear_map.coe_mk],
      change s • g _ = _,
      rw [← linear_map.map_smul, extension_of_scalars.smul_pure_tensor, mul_one], },
    { rw [map_add, map_add, ih1, ih2], }
  end,
  right_inv := λ g, begin
    ext,
    unfold forward backward,
    simp only [linear_map.coe_mk, tensor_product.lift.tmul, one_smul],
  end }.

def unit.map : X ⟶ ((extension_of_scalars.functor f ⋙ restriction_of_scalars.functor f).obj X) :=
let m1 : module R S := restriction_of_scalars.is_module f ⟨S⟩ in
{ to_fun := λ x, x ⊗ₜ[R, f] 1,
  map_add' := λ x x', by { rw tensor_product.add_tmul, },
  map_smul' := λ r x, begin
    resetI,
    erw [smul_tmul, extension_of_scalars.smul_pure_tensor],
    congr,
  end }.

def unit : 𝟭 (Module ↥R) ⟶ extension_of_scalars.functor f ⋙ restriction_of_scalars.functor f :=
{ app := unit.map f,
  naturality' := λ X X' g, begin
    ext,
    simp only [unit.map, functor.id_map, Module.coe_comp, linear_map.coe_mk,
      function.comp_app, functor.comp_map],
    rw show (restriction_of_scalars.functor f).map ((extension_of_scalars.functor f).map g) =
      { to_fun := (extension_of_scalars.functor f).map g, map_add' := _, map_smul' := _ }, from rfl,
    simp only [linear_map.coe_mk],
    erw tensor_product.lift.tmul,
    simp only [linear_map.coe_mk],
  end }

def counit.map : (restriction_of_scalars.functor f ⋙ extension_of_scalars.functor f).obj Y ⟶ Y :=
let m1 : module R S := restriction_of_scalars.is_module f ⟨S⟩,
    m2 : module R Y := restriction_of_scalars.is_module f Y in
{ to_fun :=
    begin
      resetI,
      refine tensor_product.lift
        { to_fun := λ y,
            { to_fun := λ s, _,
              map_add' := _,
              map_smul' := _ },
          map_add' := _,
          map_smul' := _ },
      { exact s • (y : Y), },
      { intros s s', rw add_smul, },
      { intros r s,
        rw [ring_hom.id_apply, restriction_of_scalars.smul_def,
          restriction_of_scalars.smul_def f ⟨S⟩ r s, smul_eq_mul, mul_smul], },
      { intros y1 y2,
        ext,
        simp only [linear_map.coe_mk, smul_add, linear_map.add_apply], },
      { intros r y,
        ext s,
        simp only [ring_hom.id_apply, restriction_of_scalars.smul_def',
          linear_map.coe_mk, linear_map.smul_apply],
        erw [← mul_smul, mul_comm, mul_smul],
        refl, },
    end,
  map_add' := λ z1 z2, by simp only [map_add],
  map_smul' := λ s z, begin
    simp only [ring_hom.id_apply],
    induction z using tensor_product.induction_on with x s' z1 z2 ih1 ih2,
    { simp only [smul_zero, map_zero], },
    { erw extension_of_scalars.smul_pure_tensor,
      simp only [linear_map.coe_mk, tensor_product.lift.tmul],
      rw mul_smul, },
    { rw [smul_add, map_add, map_add, ih1, ih2, smul_add], },
  end }.

def counit : (restriction_of_scalars.functor f ⋙ extension_of_scalars.functor f) ⟶ (𝟭 _) :=
{ app := counit.map f,
  naturality' := λ Y Y' g, begin
    ext z,
    simp only [functor.comp_map, Module.coe_comp, function.comp_app, functor.id_map],
    induction z using tensor_product.induction_on with y s z1 z2 ih1 ih2,
    { simp only [map_zero], },
    { unfold counit.map,
      erw [tensor_product.lift.tmul, tensor_product.lift.tmul],
      simp only [linear_map.coe_mk, linear_map.map_smulₛₗ, ring_hom.id_apply],
      refl, },
    { rw [map_add, map_add, ih1, ih2, map_add, map_add], }
  end }.

def adjunction : adjunction (extension_of_scalars.functor f) (restriction_of_scalars.functor f) :=
{ hom_equiv := equiv f,
  unit := unit f,
  counit := counit f,
  hom_equiv_unit' := λ X Y g, begin
    ext x,
    unfold equiv unit,
    simp only [equiv.coe_fn_mk, Module.coe_comp, function.comp_app],
    unfold unit.map forward,
    simp only [linear_map.coe_mk],
    refl,
  end,
  hom_equiv_counit' := λ X Y g, begin
    ext z,
    unfold equiv counit,
    simp only [equiv.coe_fn_symm_mk, Module.coe_comp, function.comp_app],
    unfold backward counit.map,
    simp only [linear_map.coe_mk],
    induction z using tensor_product.induction_on with x s z1 z2 ih1 ih2,
    { simp only [map_zero], },
    { erw tensor_product.lift.tmul, },
    { simp only [map_add, ih1, ih2], }
  end }.

end adjunction

end change_of_rings


-- example on parsing arith language via macros
inductive Arith: Type :=
   | Add : Arith -> Arith -> Arith
   | Int : Int -> Arith
   | Symbol : String -> Arith
   | Mul : Arith -> Arith -> Arith

declare_syntax_cat arith
syntax term : arith
syntax  "END" : arith
syntax  arith ":+" arith : arith
syntax arith ":*" arith : arith
syntax "(" arith ")" : arith

-- auxiliary notation for translating `arith` into `term`
syntax "fromArith% " arith : term

macro_rules
  | `(fromArith% $num:term) => `(Arith.Symbol $num)
  | `(fromArith% END) => `(Arith.Int 50)
  | `(fromArith% $x:arith :+ $y:arith ) => `(Arith.Add (fromArith% $x) (fromArith% $y))
  | `(fromArith% $x:arith :* $y:arith ) => `(Arith.Mul (fromArith% $x) (fromArith% $y))
  | `(fromArith% ($x:arith)) => `(fromArith% $x)

-- Remark: after this command `brack` will be a "reserved" keyword, and we will have to use `«brack»`
-- to reference the `brack` syntax category
macro "arith" n:ident "->" e:arith  : command =>
   `(def $n:ident : Arith := fromArith% $e)

arith bar -> END
#print bar

arith foo -> "x" :* "y"
#print foo

arith baz -> "x" :+ "y"
#print baz

arith baz2 -> ("x" :+ "y")
#print baz2

arith baz3 -> ("x" :+ ("z" :* "y"))
#print baz3

syntax ident : «arith»  -- Have to use french quotes since `arith` is now a keyword

macro_rules
  | `(fromArith% $x:ident) => `(Arith.Symbol $(Lean.quote (toString x.getId)))

arith foo2 -> x
#print foo2

arith foo3 -> x :+ y
#print foo3

-- arith foo2 -> x + y + z
-- #print foo2

syntax "{" term "}" : «arith» -- escape for embedding terms into `Arith`

macro_rules
  | `(fromArith% { $e }) => e

arith boo -> {foo3}
#print boo
--