/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import topology.instances.ennreal

/-!
# Probability mass functions

This file is about probability mass functions or discrete probability measures:
a function `α → ℝ≥0` such that the values have (infinite) sum `1`.

This file features the monadic structure of `pmf` and the Bernoulli distribution

## Implementation Notes

This file is not yet connected to the `measure_theory` library in any way.
At some point we need to define a `measure` from a `pmf` and prove the appropriate lemmas about
that.

## Tags

probability mass function, discrete probability measure, bernoulli distribution
-/
noncomputable theory
variables {α : Type*} {β : Type*} {γ : Type*}
open_locale classical big_operators nnreal ennreal

/-- A probability mass function, or discrete probability measures is a function `α → ℝ≥0` such that
  the values have (infinite) sum `1`. -/
def {u} pmf (α : Type u) : Type u := { f : α → ℝ≥0 // has_sum f 1 }

namespace pmf

instance : has_coe_to_fun (pmf α) := ⟨λ p, α → ℝ≥0, λ p a, p.1 a⟩

@[ext] protected lemma ext : ∀ {p q : pmf α}, (∀ a, p a = q a) → p = q
| ⟨f, hf⟩ ⟨g, hg⟩ eq :=  subtype.eq $ funext eq

lemma has_sum_coe_one (p : pmf α) : has_sum p 1 := p.2

lemma summable_coe (p : pmf α) : summable p := (p.has_sum_coe_one).summable

@[simp] lemma tsum_coe (p : pmf α) : ∑' a, p a = 1 := p.has_sum_coe_one.tsum_eq

/-- The support of a `pmf` is the set where it is nonzero. -/
def support (p : pmf α) : set α := {a | p.1 a ≠ 0}

@[simp] lemma mem_support_iff (p : pmf α) (a : α) :
  a ∈ p.support ↔ p a ≠ 0 := iff.rfl

/-- The pure `pmf` is the `pmf` where all the mass lies in one point.
  The value of `pure a` is `1` at `a` and `0` elsewhere. -/
def pure (a : α) : pmf α := ⟨λ a', if a' = a then 1 else 0, has_sum_ite_eq _ _⟩

@[simp] lemma pure_apply (a a' : α) : pure a a' = (if a' = a then 1 else 0) := rfl

lemma mem_support_pure_iff (a a' : α) : a' ∈ (pure a).support ↔ a' = a :=
by simp

instance [inhabited α] : inhabited (pmf α) := ⟨pure (default α)⟩

lemma coe_le_one (p : pmf α) (a : α) : p a ≤ 1 :=
has_sum_le (by intro b; split_ifs; simp [h]; exact le_refl _) (has_sum_ite_eq a (p a)) p.2

protected lemma bind.summable (p : pmf α) (f : α → pmf β) (b : β) :
  summable (λ a : α, p a * f a b) :=
begin
  refine nnreal.summable_of_le (assume a, _) p.summable_coe,
  suffices : p a * f a b ≤ p a * 1, { simpa },
  exact mul_le_mul_of_nonneg_left ((f a).coe_le_one _) (p a).2
end

/-- The monadic bind operation for `pmf`. -/
def bind (p : pmf α) (f : α → pmf β) : pmf β :=
⟨λ b, ∑'a, p a * f a b,
  begin
    apply ennreal.has_sum_coe.1,
    simp only [ennreal.coe_tsum (bind.summable p f _)],
    rw [ennreal.summable.has_sum_iff, ennreal.tsum_comm],
    simp [ennreal.tsum_mul_left, (ennreal.coe_tsum (f _).summable_coe).symm,
      (ennreal.coe_tsum p.summable_coe).symm]
  end⟩

@[simp] lemma bind_apply (p : pmf α) (f : α → pmf β) (b : β) : p.bind f b = ∑'a, p a * f a b :=
rfl

lemma coe_bind_apply (p : pmf α) (f : α → pmf β) (b : β) :
  (p.bind f b : ℝ≥0∞) = ∑'a, p a * f a b :=
eq.trans (ennreal.coe_tsum $ bind.summable p f b) $ by simp

@[simp] lemma pure_bind (a : α) (f : α → pmf β) : (pure a).bind f = f a :=
have ∀ b a', ite (a' = a) 1 0 * f a' b = ite (a' = a) (f a b) 0, from
  assume b a', by split_ifs; simp; subst h; simp,
by ext b; simp [this]

@[simp] lemma bind_pure (p : pmf α) : p.bind pure = p :=
have ∀ a a', (p a * ite (a' = a) 1 0) = ite (a = a') (p a') 0, from
  assume a a', begin split_ifs; try { subst a }; try { subst a' }; simp * at * end,
by ext b; simp [this]

@[simp] lemma bind_bind (p : pmf α) (f : α → pmf β) (g : β → pmf γ) :
  (p.bind f).bind g = p.bind (λ a, (f a).bind g) :=
begin
  ext1 b,
  simp only [ennreal.coe_eq_coe.symm, coe_bind_apply, ennreal.tsum_mul_left.symm,
             ennreal.tsum_mul_right.symm],
  rw [ennreal.tsum_comm],
  simp [mul_assoc, mul_left_comm, mul_comm]
end

lemma bind_comm (p : pmf α) (q : pmf β) (f : α → β → pmf γ) :
  p.bind (λ a, q.bind (f a)) = q.bind (λ b, p.bind (λ a, f a b)) :=
begin
  ext1 b,
  simp only [ennreal.coe_eq_coe.symm, coe_bind_apply, ennreal.tsum_mul_left.symm,
             ennreal.tsum_mul_right.symm],
  rw [ennreal.tsum_comm],
  simp [mul_assoc, mul_left_comm, mul_comm]
end

protected lemma bind_on_support.summable (p : pmf α) (f : ∀ a ∈ p.support, pmf β) (b : β) :
  summable (λ a : α, p a * if h : p a = 0 then 0 else f a h b) :=
begin
  refine nnreal.summable_of_le (assume a, _) p.summable_coe,
  split_ifs,
  { refine (mul_zero (p a)).symm ▸ le_of_eq h.symm },
  { suffices : p a * f a h b ≤ p a * 1, { simpa },
    exact mul_le_mul_of_nonneg_left ((f a h).coe_le_one _) (p a).2 }
end

/-- Generalized version of `bind` allowing `f` to only be defined on the support of `p`.
  `p.bind f` is equivalent to `p.bind_on_support (λ a _, f a)`, see `bind_on_support_eq_bind` -/
def bind_on_support (p : pmf α) (f : ∀ a ∈ p.support, pmf β) : pmf β :=
⟨λ b, ∑' a, p a * if h : p a = 0 then 0 else f a h b,
ennreal.has_sum_coe.1 begin
  simp only [ennreal.coe_tsum (bind_on_support.summable p f _)],
  rw [ennreal.summable.has_sum_iff, ennreal.tsum_comm],
  simp only [ennreal.coe_mul, ennreal.coe_one, ennreal.tsum_mul_left],
  have : ∑' (a : α), (p a : ennreal) = 1 :=
    by simp only [←ennreal.coe_tsum p.summable_coe, ennreal.coe_one, tsum_coe],
  refine trans (tsum_congr (λ a, _)) this,
  split_ifs with h,
  { simp [h] },
  { simp [← ennreal.coe_tsum (f a h).summable_coe, (f a h).tsum_coe] }
end⟩

@[simp] lemma bind_on_support_apply (p : pmf α) (f : ∀ a ∈ p.support, pmf β) (b : β) :
  p.bind_on_support f b = ∑' a, p a * if h : p a = 0 then 0 else f a h b := rfl

/-- `bind_on_support` reduces to `bind` if `f` doesn't depend on the additional hypothesis -/
@[simp] lemma bind_on_support_eq_bind (p : pmf α) (f : α → pmf β) :
  p.bind_on_support (λ a _, f a) = p.bind f :=
begin
  ext b,
  simp only [p.bind_on_support_apply (λ a _, f a), p.bind_apply f,
    dite_eq_ite, nnreal.coe_eq, mul_ite, mul_zero],
  refine congr_arg _ (funext (λ a, _)),
  split_ifs with h; simp [h],
end

lemma coe_bind_on_support_apply (p : pmf α) (f : ∀ a ∈ p.support, pmf β) (b : β) :
  (p.bind_on_support f b : ℝ≥0∞) = ∑' a, p a * if h : p a = 0 then 0 else f a h b :=
by simp only [bind_on_support_apply, ennreal.coe_tsum (bind_on_support.summable p f b),
    dite_cast, ennreal.coe_mul, ennreal.coe_zero]

@[simp] lemma mem_support_bind_on_support_iff (p : pmf α) (f : ∀ a ∈ p.support, pmf β) (b : β) :
  b ∈ (p.bind_on_support f).support ↔ ∃ a (ha : p a ≠ 0), b ∈ (f a ha).support :=
begin
  simp only [mem_support_iff, bind_on_support_apply,
    tsum_ne_zero_iff (bind_on_support.summable p f b), mul_ne_zero_iff],
  split; { rintro ⟨a, ha, haf⟩, refine ⟨a, ha, ne_of_eq_of_ne _ haf⟩, simp [ha], },
end

lemma bind_on_support_eq_zero_iff (p : pmf α) (f : ∀ a ∈ p.support, pmf β) (b : β) :
  p.bind_on_support f b = 0 ↔ ∀ a (ha : p a ≠ 0), f a ha b = 0 :=
begin
  simp only [bind_on_support_apply, tsum_eq_zero_iff (bind_on_support.summable p f b),
    mul_eq_zero, or_iff_not_imp_left],
  exact ⟨λ h a ha, trans (dif_neg ha).symm (h a ha), λ h a ha, trans (dif_neg ha) (h a ha)⟩,
end

@[simp] lemma pure_bind_on_support (a : α) (f : ∀ (a' : α) (ha : a' ∈ (pure a).support), pmf β) :
  (pure a).bind_on_support f = f a ((mem_support_pure_iff a a).mpr rfl) :=
begin
  refine pmf.ext (λ b, _),
  simp only [nnreal.coe_eq, bind_on_support_apply, pure_apply],
  refine trans (tsum_congr (λ a', _)) (tsum_ite_eq a _),
  by_cases h : (a' = a); simp [h],
end

lemma bind_on_support_pure (p : pmf α) :
  p.bind_on_support (λ a _, pure a) = p :=
by simp only [pmf.bind_pure, pmf.bind_on_support_eq_bind]

@[simp] lemma bind_on_support_bind_on_support (p : pmf α)
  (f : ∀ a ∈ p.support, pmf β)
  (g : ∀ (b ∈ (p.bind_on_support f).support), pmf γ) :
  (p.bind_on_support f).bind_on_support g =
    p.bind_on_support (λ a ha, (f a ha).bind_on_support
      (λ b hb, g b ((p.mem_support_bind_on_support_iff f b).mpr ⟨a, ha, hb⟩))) :=
begin
  refine pmf.ext (λ a, _),
  simp only [ennreal.coe_eq_coe.symm, coe_bind_on_support_apply, ← tsum_dite_right,
    ennreal.tsum_mul_left.symm, ennreal.tsum_mul_right.symm],
  refine trans (ennreal.tsum_comm) (tsum_congr (λ a', _)),
  split_ifs with h,
  { simp only [h, ennreal.coe_zero, zero_mul, tsum_zero] },
  { simp only [← ennreal.tsum_mul_left, ← mul_assoc],
    refine tsum_congr (λ b, _),
    split_ifs with h1 h2 h2,
    any_goals { ring1 },
    { rw bind_on_support_eq_zero_iff at h1,
      simp only [h1 a' h, ennreal.coe_zero, zero_mul, mul_zero] },
    { simp only [h2, ennreal.coe_zero, mul_zero, zero_mul] } }
end

lemma bind_on_support_comm (p : pmf α) (q : pmf β)
  (f : ∀ (a ∈ p.support) (b ∈ q.support), pmf γ) :
  p.bind_on_support (λ a ha, q.bind_on_support (f a ha)) =
    q.bind_on_support (λ b hb, p.bind_on_support (λ a ha, f a ha b hb)) :=
begin
  apply pmf.ext, rintro c,
  simp only [ennreal.coe_eq_coe.symm, coe_bind_on_support_apply, ← tsum_dite_right,
    ennreal.tsum_mul_left.symm, ennreal.tsum_mul_right.symm],
  refine trans (ennreal.tsum_comm) (tsum_congr (λ b, tsum_congr (λ a, _))),
  split_ifs with h1 h2 h2; ring,
end

/-- The functorial action of a function on a `pmf`. -/
def map (f : α → β) (p : pmf α) : pmf β := bind p (pure ∘ f)

lemma bind_pure_comp (f : α → β) (p : pmf α) : bind p (pure ∘ f) = map f p := rfl

lemma map_id (p : pmf α) : map id p = p := by simp [map]

lemma map_comp (p : pmf α) (f : α → β) (g : β → γ) : (p.map f).map g = p.map (g ∘ f) :=
by simp [map]

lemma pure_map (a : α) (f : α → β) : (pure a).map f = pure (f a) :=
by simp [map]

/-- The monadic sequencing operation for `pmf`. -/
def seq (f : pmf (α → β)) (p : pmf α) : pmf β := f.bind (λ m, p.bind $ λ a, pure (m a))

/-- Given a non-empty multiset `s` we construct the `pmf` which sends `a` to the fraction of
  elements in `s` that are `a`. -/
def of_multiset (s : multiset α) (hs : s ≠ 0) : pmf α :=
⟨λ a, s.count a / s.card,
  have ∑ a in s.to_finset, (s.count a : ℝ) / s.card = 1,
    by simp [div_eq_inv_mul, finset.mul_sum.symm, (finset.sum_nat_cast _ _).symm, hs],
  have ∑ a in s.to_finset, (s.count a : ℝ≥0) / s.card = 1,
    by rw [← nnreal.eq_iff, nnreal.coe_one, ← this, nnreal.coe_sum]; simp,
  begin
    rw ← this,
    apply has_sum_sum_of_ne_finset_zero,
    simp {contextual := tt},
  end⟩

/-- Given a finite type `α` and a function `f : α → ℝ≥0` with sum 1, we get a `pmf`. -/
def of_fintype [fintype α] (f : α → ℝ≥0) (h : ∑ x, f x = 1) : pmf α :=
⟨f, h ▸ has_sum_sum_of_ne_finset_zero (by simp)⟩

/-- Given a `f` with non-zero sum, we get a `pmf` by normalizing `f` by its `tsum` -/
def normalize (f : α → ℝ≥0) (hf0 : tsum f ≠ 0) : pmf α :=
⟨λ a, f a * (∑' x, f x)⁻¹,
  (mul_inv_cancel hf0) ▸ has_sum.mul_right (∑' x, f x)⁻¹
    (not_not.mp (mt tsum_eq_zero_of_not_summable hf0 : ¬¬summable f)).has_sum⟩

lemma normalize_apply {f : α → ℝ≥0} (hf0 : tsum f ≠ 0) (a : α) :
  (normalize f hf0) a = f a * (∑' x, f x)⁻¹ := rfl

/-- Create new `pmf` by filtering on a set with non-zero measure and normalizing -/
def filter (p : pmf α) (s : set α) (h : ∃ a ∈ s, p a ≠ 0) : pmf α :=
pmf.normalize (s.indicator p) $ nnreal.tsum_indicator_ne_zero p.2.summable h

lemma filter_apply (p : pmf α) {s : set α} (h : ∃ a ∈ s, p a ≠ 0) {a : α} :
  (p.filter s h) a = (s.indicator p a) * (∑' x, (s.indicator p) x)⁻¹ :=
by rw [filter, normalize_apply]

lemma filter_apply_eq_zero_of_not_mem (p : pmf α) {s : set α} (h : ∃ a ∈ s, p a ≠ 0)
  {a : α} (ha : a ∉ s) : (p.filter s h) a = 0 :=
by rw [filter_apply, set.indicator_apply_eq_zero.mpr (λ ha', absurd ha' ha), zero_mul]

lemma filter_apply_eq_zero_iff (p : pmf α) {s : set α} (h : ∃ a ∈ s, p a ≠ 0) (a : α) :
  (p.filter s h) a = 0 ↔ a ∉ (p.support ∩ s) :=
begin
  rw [set.mem_inter_iff, p.mem_support_iff, not_and_distrib, not_not],
  split; intro ha,
  { rw [filter_apply, mul_eq_zero] at ha,
    refine ha.by_cases
      (λ ha, (em (a ∈ s)).by_cases (λ h, or.inl ((set.indicator_apply_eq_zero.mp ha) h)) or.inr)
      (λ ha, absurd (inv_eq_zero.1 ha) (nnreal.tsum_indicator_ne_zero p.2.summable h)) },
  { rw [filter_apply, set.indicator_apply_eq_zero.2 (λ h, ha.by_cases id (absurd h)), zero_mul] }
end

lemma filter_apply_ne_zero_iff (p : pmf α) {s : set α} (h : ∃ a ∈ s, p a ≠ 0) (a : α) :
  (p.filter s h) a ≠ 0 ↔ a ∈ (p.support ∩ s) :=
by rw [← not_iff, filter_apply_eq_zero_iff, not_iff, not_not]

/-- A `pmf` which assigns probability `p` to `tt` and `1 - p` to `ff`. -/
def bernoulli (p : ℝ≥0) (h : p ≤ 1) : pmf bool :=
of_fintype (λ b, cond b p (1 - p)) (nnreal.eq $ by simp [h])

end pmf


variable {α : Type*}

def is_prefix (l₁ : list α) (l₂ : list α) : Prop :=
∃ t, l₁ ++ t = l₂

#check is_prefix

def list_has_le : has_le (list α) := ⟨is_prefix⟩

#check list_has_le

#check has_le
#print has_le

section
local attribute [instance] list_has_le

theorem foo (l : list α) : l ≤ l := ⟨[], by simp⟩
end

-- theorem bar (l : list α) : l ≤ l := ⟨[], by simp⟩


import analysis.inner_product_space.projection
import analysis.normed_space.lp_space
import analysis.inner_product_space.l2_space
import analysis.inner_product_space.pi_L2

open is_R_or_C submodule filter
open_locale big_operators nnreal ennreal classical complex_conjugate

noncomputable theory

-- Currently just throwing in everything from hilbert_space, editing as necessary
-- Should be able to get rid of [complete_space E]
variables {ι : Type*}
variables {𝕜 : Type*} [is_R_or_C 𝕜] {E : Type*} [inner_product_space 𝕜 E] [fintype ι]
variables {G : ι → Type*} [Π i, inner_product_space 𝕜 (G i)]
local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

variables (ι) (𝕜) (E)

def euclidean_space.single {𝕜 : Type*} {ι : Type*} [fintype ι] [is_R_or_C 𝕜] (i : ι) (a : 𝕜): euclidean_space 𝕜 ι :=
  -- lp.single 2 i (a : 𝕜)
  set.indicator {i} (λ j, a)

theorem euclidean_space.single_apply {𝕜 : Type*} {ι : Type*} [fintype ι] [is_R_or_C 𝕜] (i : ι) (a : 𝕜) (j : ι) :
  (euclidean_space.single i a) j = dite (j = i) (λ (h : j = i), a) (λ (h : ¬j = i), 0) :=
  begin
    rw euclidean_space.single,
    rw dite_eq_ite,
    rw set.indicator,
    simp only [set.mem_singleton_iff],
  end

lemma euclidean_space.inner_single_left (i : ι) (a : 𝕜) (v : euclidean_space 𝕜 ι) :
  ⟪ euclidean_space.single i (a : 𝕜), v ⟫ = star_ring_end 𝕜 a * (v i) :=
  begin
    simp only [is_R_or_C.inner_apply, pi_Lp.inner_apply, finset.sum_congr],
    rw euclidean_space.single,
    conv
    begin
      to_lhs,
      congr,
      skip,
      funext,
      rw set.indicator,
    end,
    simp only [dite_eq_ite, eq_rec_constant, dif_ctx_congr, finset.sum_congr],
    conv
    begin
      to_lhs,
      congr,
      skip,
      funext,
      rw apply_ite (star_ring_end 𝕜),
      rw @star_ring_end_apply _ _ _ (0 : 𝕜),
      rw star_zero,
      rw ite_mul,
    end,
    simp only [finset.mem_univ,
 if_true,
 set.mem_singleton_iff,
 mul_eq_mul_left_iff,
 zero_mul,
 true_or,
 eq_self_iff_true,
 finset.sum_ite_eq',
 ring_hom.map_eq_zero,
 finset.sum_congr],
  end

lemma euclidean_space.inner_single_right (i : ι) (a : 𝕜) (v : euclidean_space 𝕜 ι) :
  ⟪ v, euclidean_space.single i (a : 𝕜) ⟫ =  a * (star_ring_end 𝕜) (v i) :=
  begin
    rw [← inner_conj_sym, euclidean_space.inner_single_left],
    rw star_ring_end_apply,
    rw star_mul',
    rw ← star_ring_end_apply,
    rw ← star_ring_end_apply,
    rw star_ring_end_self_apply,
  end

/-- An orthonormal basis on E is an identification of `E` with its dimensional-matching `euclidean_space`. -/
structure orthonormal_basis := of_repr :: (repr : E ≃ₗᵢ[𝕜] euclidean_space 𝕜 ι)

namespace orthonormal_basis

instance : inhabited (orthonormal_basis ι 𝕜 (euclidean_space 𝕜 ι)) :=
  ⟨of_repr (linear_isometry_equiv.refl 𝕜 (euclidean_space 𝕜 ι)) ⟩

/-- `b i` is the `i`th basis vector. -/
instance : has_coe_to_fun (orthonormal_basis ι 𝕜 E) (λ _, ι → E) :=
{
  coe := λ b i, b.repr.symm (euclidean_space.single i (1 : 𝕜))
}

@[simp] protected lemma repr_symm_single (b : orthonormal_basis ι 𝕜 E) (i : ι) :
  b.repr.symm (euclidean_space.single i (1:𝕜)) = b i :=
rfl

@[simp] protected lemma repr_self (b : orthonormal_basis ι 𝕜 E) (i : ι) :
  b.repr (b i) = euclidean_space.single i (1:𝕜) :=
  begin
    rw [← b.repr_symm_single _ _ _, linear_isometry_equiv.apply_symm_apply],
  end

protected lemma repr_apply_apply (b : orthonormal_basis ι 𝕜 E) (v : E) (i : ι) :
  b.repr v i = ⟪b i, v⟫ :=
begin
  rw [← b.repr.inner_map_map (b i) v, b.repr_self _ _ _, euclidean_space.inner_single_left],
  simp only [one_mul, eq_self_iff_true, map_one],
end

@[simp]
protected lemma orthonormal (b : orthonormal_basis ι 𝕜 E) : orthonormal 𝕜 b :=
begin
  rw orthonormal_iff_ite,
  intros i j,
  rw [← b.repr.inner_map_map (b i) (b j), b.repr_self _ _ _, b.repr_self _ _ _],
  rw euclidean_space.inner_single_left,
  rw euclidean_space.single_apply,
  simp only [mul_boole, dite_eq_ite, eq_self_iff_true, map_one],
end

protected lemma sum_repr_symm (b : orthonormal_basis ι 𝕜 E) (v : euclidean_space 𝕜 ι) :
  ∑ i , v i • b i = (b.repr.symm v) :=
  begin
    have : b.repr (∑ i, v i • b i) = v :=
    begin
      have : ⇑(b.repr) = (b.repr.to_linear_isometry.to_linear_map) :=
      begin
        simp only [linear_isometry.coe_to_linear_map, fun_like.coe_fn_eq, linear_isometry_equiv.coe_to_linear_isometry, eq_self_iff_true],
      end,
    rw this,
    simp_rw [linear_map.map_sum, linear_map.map_smul, ← this],
    ext i,
    change (∑ (c : ι), (λ x, v x • (b.repr) (b x)) c) i = v i,
    rw [@fintype.sum_apply _ _ ι _ _ i (λ x, v x • (b.repr) (b x))],
    simp only [algebra.id.smul_eq_mul, orthonormal_basis.repr_self, pi.smul_apply, finset.sum_congr],
    simp_rw [euclidean_space.single, set.indicator, mul_ite, mul_zero],
    simp only [mul_one, finset.mem_univ, if_true, set.mem_singleton_iff, eq_self_iff_true, finset.sum_congr, finset.sum_ite_eq],
    end,
    conv_rhs
    begin
    rw ← this,
    end,
    simp only [linear_isometry_equiv.symm_apply_apply, eq_self_iff_true],
  end

variables {ι} {𝕜} {E}
variable {v : ι → E}

/-- An orthonormal set that spans is an orthonormal basis -/
protected def mk (hon : orthonormal 𝕜 v) (hsp: submodule.span 𝕜 (set.range v) = ⊤): orthonormal_basis ι 𝕜 E :=
  orthonormal_basis.of_repr $
  basis.isometry_euclidean_of_orthonormal (basis.mk (orthonormal.linear_independent hon) hsp)
  begin
    rw basis.coe_mk,
    exact hon,
  end

@[simp]
protected lemma coe_mk (hon : orthonormal 𝕜 v) (hsp: submodule.span 𝕜 (set.range v) = ⊤) :
  ⇑(orthonormal_basis.mk hon hsp) = v :=
begin
  ext i,
  show (orthonormal_basis.mk hon hsp).repr.symm _ = v i,
  simp only [basis.coe_isometry_euclidean_of_orthonormal_symm,
 orthonormal_basis.mk.equations._eqn_1,
 basis.coe_mk,
 basis.equiv_fun_symm_apply,
 finset.sum_congr],
 conv
 begin
   to_lhs,
   congr,
   skip,
   funext,
    rw euclidean_space.single_apply,
    rw dite_eq_ite,
  rw ite_smul,
 end,
  simp only [finset.mem_univ,
 if_true,
 eq_self_iff_true,
 one_smul,
 finset.sum_ite_eq',
 zero_smul,
 finset.sum_congr],
end

/-- A basis that is orthonormal is an orthonormal basis. -/
def _root_.basis.to_orthonormal_basis (b : basis ι 𝕜 E) (hb : orthonormal 𝕜 b) :
  orthonormal_basis ι 𝕜 E :=
    orthonormal_basis.of_repr(basis.isometry_euclidean_of_orthonormal b hb)

end orthonormal_basis


/- -----------------------------------------------------------------------
Boxes of homs in a category.
----------------------------------------------------------------------- -/

import .s1_categories

namespace qp

open stdaux

universe variables ℓ ℓobj ℓhom ℓobj₁ ℓhom₁ ℓobj₂ ℓhom₂

/- -----------------------------------------------------------------------
Boxes full of homs.
----------------------------------------------------------------------- -/

/-! #brief Type of dlist used for defining Hom.
-/
@[reducible] definition HomAt (C : Cat.{ℓobj ℓhom})
    : prod C^.obj C^.obj → Sort ℓhom
:= λ cc, C^.hom cc^.fst cc^.snd

/-! #brief A list of homs in a category.
-/
definition HomsList (C : Cat.{ℓobj ℓhom})
    (ccs : list (prod C^.obj C^.obj))
:= dlist (HomAt C) ccs

/-! #brief The nil HomsList.
-/
definition HomsList.nil {C : Cat.{ℓobj ℓhom}}
    : HomsList C []
:= dlist.nil _

/-! #brief Push another hom onto a HomsList.
-/
definition HomsList.cons {C : Cat.{ℓobj ℓhom}}
    {x y : C^.obj} (f : C^.hom x y)
    {ccs : list (prod C^.obj C^.obj)} (tail : HomsList C ccs)
    : HomsList C ((x,y) :: ccs)
:= dlist.cons _ f _ tail

infixr `↗` : 50 := HomsList.cons
notation f `↗↗` := HomsList.cons f HomsList.nil

example {C : Cat.{ℓobj ℓhom}}
        {a₁ a₂ b₁ b₂ c₁ c₂ : C^.obj}
        (fa : C^.hom a₁ a₂)
        (fb : C^.hom b₁ b₂)
        (fc : C^.hom c₁ c₂)
        : HomsList C [(a₁, a₂), (b₁, b₂), (c₁, c₂)]
:= fa ↗ fb ↗ fc ↗↗

/-! #brief Helper for equality of HomsList.cons.
-/
theorem HomsList.eq {C : Cat.{ℓobj ℓhom}}
    {x y : C^.obj} {f₁ f₂ : C^.hom x y}
    {ccs : list (prod C^.obj C^.obj)} {tail₁ tail₂ : HomsList C ccs}
    (ωf : f₁ = f₂)
    (ωtail : tail₁ = tail₂)
    : HomsList.cons f₁ tail₁ = HomsList.cons f₂ tail₂
:= dlist.eq ωf ωtail

/-! #brief Listing the identity homs.
-/
definition HomsList.id {C : Cat.{ℓobj ℓhom}}
    : ∀ (factor : list C^.obj)
      , HomsList C (list.map prod.diag factor)
| [] := HomsList.nil
| (factor :: factors) := HomsList.cons (C^.id factor) (HomsList.id factors)

/-! #brief Mapping a construction across a homs list.
-/
definition HomsList.map' {C : Cat.{ℓobj ℓhom}}
    {A : Type ℓ} (f : ∀ {x y : C^.obj}, C^.hom x y → A)
    : ∀ {doms_codoms : list (prod C^.obj C^.obj)}
      , HomsList C doms_codoms → list A
| [] homs := []
| ((prod.mk a b) :: doms_codoms) (dlist.cons .(_) hom .(_) homs)
:= f hom :: HomsList.map' homs

/-! #brief Generating a HomsList from a list.
-/
definition HomsList.from_list {C : Cat.{ℓobj ℓhom}}
    {A : Type ℓ}
    {f_dom : A → C^.obj} {f_codom : A → C^.obj}
    (f : ∀ (a : A), C^.hom (f_dom a) (f_codom a))
    : ∀ (aa : list A)
      , HomsList C (list.map (λ (a : A), (f_dom a, f_codom a)) aa)
| [] := HomsList.nil
| (a :: aa) := HomsList.cons (f a) (HomsList.from_list aa)

/-! #brief Fetching a hom out of HomsList.
-/
definition HomsList.get {C : Cat.{ℓobj ℓhom}}
    {ccs : list (prod C^.obj C^.obj)}
    (homs : HomsList C ccs)
    (n : fin (list.length ccs))
    : C^.hom (list.get ccs n)^.fst (list.get ccs n)^.snd
:= dlist.get homs n

/-! #brief Congruence for HomsList.get.
-/
theorem HomsList.congr_get {C : Cat.{ℓobj ℓhom}}
    {ccs : list (prod C^.obj C^.obj)}
    {homs₁ homs₂ : HomsList C ccs}
    (ωhoms : homs₁ = homs₂)
    (n : fin (list.length ccs))
    : HomsList.get homs₁ n = HomsList.get homs₂ n
:= dlist.congr_get ωhoms n

/-! #brief Repeat a hom N times.
-/
definition HomsList.repeat {C : Cat.{ℓobj ℓhom}}
    {x y : C^.obj}
    (f : C^.hom x y) (N : ℕ)
    : HomsList C (list.repeat (x, y) N)
:= dlist.repeat f N

/-! #brief Action of get on repeat.
-/
theorem HomsList.get_repeat {C : Cat.{ℓobj ℓhom}}
    {x y : C^.obj}
    (f : C^.hom x y) {N : ℕ}
    (n : fin N)
    : HomsList.get (HomsList.repeat f N) { val := n^.val, is_lt := begin rw list.length_repeat, exact n^.is_lt end }
       == f
:= by apply @dlist.get_repeat _ (HomAt C)

/- -----------------------------------------------------------------------
Boxes full of homs out of an object.
----------------------------------------------------------------------- -/

/-! #brief Outward homs.
-/
definition HomsOut {C : Cat.{ℓobj ℓhom}}
    (c : C^.obj)
    (factor : list C^.obj)
    : Type (max ℓobj ℓhom)
:= dlist (C^.hom c) factor

/-! #brief The nil HomsOut.
-/
definition HomsOut.nil {C : Cat.{ℓobj ℓhom}}
    {c : C^.obj}
    : HomsOut c []
:= dlist.nil _

/-! #brief Push another hom onto a HomsOut.
-/
definition HomsOut.cons {C : Cat.{ℓobj ℓhom}}
    {x c : C^.obj} (f : C^.hom c x)
    {factor : list C^.obj} (tail : HomsOut c factor)
    : HomsOut c (x :: factor)
:= dlist.cons _ f _ tail

infixr `↗←` : 50 := HomsOut.cons
notation f `↗←↗` := HomsOut.cons f HomsOut.nil

/-! #brief Composition with outward homs.
-/
definition HomsOut.comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj : HomsOut c factor)
    {c' : C^.obj} (f : C^.hom c' c)
    : HomsOut c' factor
:= dlist.map (λ a j, C^.circ j f) proj

/-! #brief HomsOut.comp distributes over composition of homs.
-/
definition HomsOut.comp_circ {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj : HomsOut c factor)
    {c₁ c₂ : C^.obj} (g : C^.hom c₂ c) (f : C^.hom c₁ c₂)
    : HomsOut.comp proj (C^.circ g f)
       = HomsOut.comp (HomsOut.comp proj g) f
:= begin
     unfold HomsOut.comp,
     apply eq.symm,
     refine eq.trans (dlist.map_map _ _) _,
     refine congr_arg (λ f, dlist.map f proj) _,
     apply funext, intro a, apply funext, intro j,
     apply eq.symm C^.circ_assoc
   end

/-! #brief Composition of a HomsList with a HomsOut.
-/
definition homs_comp_out {C : Cat.{ℓobj ℓhom}}
    : ∀ {ccs : list (prod C^.obj C^.obj)}
        (fns : HomsList C ccs)
        {c : C^.obj}
        (c_proj : HomsOut c (list.map prod.fst ccs))
      , HomsOut c (list.map prod.snd ccs)
:= λ ccs fns c c_proj
   , begin
       induction ccs with cc ccs rec,
       { apply dlist.nil },
       { cases fns with cc f ccs fns',
         cases cc with c₁ c₂,
         cases c_proj with c₁ p ccs c_proj',
         apply dlist.cons _ (C^.circ f p) _ (rec fns' c_proj')
       }
     end

/-! #brief Fetching a hom out of HomsOut.
-/
definition HomsOut.get {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj : HomsOut c factor)
    (n : fin (list.length factor))
    : C^.hom c (list.get factor n)
:= dlist.get proj n

/-! #brief get is injective.
-/
theorem HomsOut.get.inj {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj₁ proj₂ : HomsOut c factor)
    (ω : HomsOut.get proj₁ = HomsOut.get proj₂)
    : proj₁ = proj₂
:= dlist.get.inj ω

/-! #brief get on comp.
-/
theorem HomsOut.get_comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    {proj : HomsOut c factor}
    {c' : C^.obj} {f : C^.hom c' c}
    {n : fin (list.length factor)}
    : HomsOut.get (HomsOut.comp proj f) n = C^.circ (HomsOut.get proj n) f
:= dlist.get_map _ _ _

/-! #brief An inverse to HomsOut.get.
-/
definition HomsOut.enum {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (f : ∀ (n : fin (list.length factor)), C^.hom c (list.get factor n))
    : HomsOut c factor
:= dlist.enum f

/-! #brief enum and get are inverses.
-/
theorem HomsOut.enum_get {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj : HomsOut c factor)
    : HomsOut.enum (HomsOut.get proj) = proj
:= dlist.enum_get

/-! #brief enum and get are inverses.
-/
theorem HomsOut.get_enum {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (f : ∀ (n : fin (list.length factor)), C^.hom c (list.get factor n))
    (n : fin (list.length factor))
    : HomsOut.get (HomsOut.enum f) n = f n
:= dlist.get_enum _ _

/-! #brief Appending lists of outward homs.
-/
definition HomsOut.append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsOut c factor₁)
    (proj₂ : HomsOut c factor₂)
    : HomsOut c (factor₁ ++ factor₂)
:= dlist.append proj₁ proj₂

/-! #brief Splitting lists of outward homs.
-/
definition HomsOut.split_left {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsOut c (factor₁ ++ factor₂))
    : HomsOut c factor₁
:= dlist.split_left factor₁ proj

/-! #brief Splitting lists of outward homs.
-/
definition HomsOut.split_right {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsOut c (factor₁ ++ factor₂))
    : HomsOut c factor₂
:= dlist.split_right factor₁ proj

/-! #brief Equality of HomsOut.append
-/
theorem HomsOut.append_eq {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ proj₂ : HomsOut c (factor₁ ++ factor₂))
    (ωleft : HomsOut.split_left proj₁ = HomsOut.split_left proj₂)
    (ωright : HomsOut.split_right proj₁ = HomsOut.split_right proj₂)
    : proj₁ = proj₂
:= dlist.append_eq ωleft ωright

/-! #brief Action of split_left on append.
-/
theorem HomsOut.split_left_append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsOut c factor₁)
    (proj₂ : HomsOut c factor₂)
    : HomsOut.split_left (HomsOut.append proj₁ proj₂)
       = proj₁
:= dlist.split_left_append

/-! #brief Action of split_right on append.
-/
theorem HomsOut.split_right_append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsOut c factor₁)
    (proj₂ : HomsOut c factor₂)
    : HomsOut.split_right (HomsOut.append proj₁ proj₂)
       = proj₂
:= dlist.split_right_append

/-! #brief Action of split_left on comp.
-/
theorem HomsOut.split_left_comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsOut c (factor₁ ++ factor₂))
    {c' : C^.obj} (f : C^.hom c' c)
    : HomsOut.split_left (HomsOut.comp proj f)
       = HomsOut.comp (HomsOut.split_left proj) f
:= dlist.split_left_map _

/-! #brief Action of split_right on comp.
-/
theorem HomsOut.split_right_comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsOut c (factor₁ ++ factor₂))
    {c' : C^.obj} (f : C^.hom c' c)
    : HomsOut.split_right (HomsOut.comp proj f)
       = HomsOut.comp (HomsOut.split_right proj) f
:= dlist.split_right_map _

/-! #brief Action of get on an append.
-/
theorem HomsOut.get_append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsOut c factor₁)
    (proj₂ : HomsOut c factor₂)
    (n : ℕ) (ωn : n < list.length factor₁)
    : HomsOut.get (HomsOut.append proj₁ proj₂) (fin.mk n (list.length.grow_left ωn))
       == HomsOut.get proj₁ (fin.mk n ωn)
:= dlist.get_append

/-! #brief Action of get on split_left.
-/
theorem HomsOut.get_split_left {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    {proj : HomsOut c (factor₁ ++ factor₂)}
    {n : ℕ} {ωn : n < list.length factor₁}
    : HomsOut.get (HomsOut.split_left proj) (fin.mk n ωn)
       = cast_hom list.get_append_left
          ∘∘ HomsOut.get proj (fin.mk n (list.length.grow_left ωn))
:= begin
     apply eq_of_heq,
     refine heq.trans _ (heq.symm (cast_hom.circ_left_heq _ _)),
     apply dlist.get_split_left
   end

/-! #brief Action of get on split_right.
-/
theorem HomsOut.get_split_right {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    {proj : HomsOut c (factor₁ ++ factor₂)}
    {n : ℕ} {ωn : n < list.length factor₂}
    : HomsOut.get (HomsOut.split_right proj) (fin.mk n ωn)
       = cast_hom list.get_append_right
          ∘∘ HomsOut.get proj (fin.mk (n + list.length factor₁) (list.length.grow_right ωn))
:= begin
     apply eq_of_heq,
     refine heq.trans _ (heq.symm (cast_hom.circ_left_heq _ _)),
     apply dlist.get_split_right
   end

/- -----------------------------------------------------------------------
Boxes full of homs into an object.
----------------------------------------------------------------------- -/

/-! #brief Inward homs.
-/
definition HomsIn {C : Cat.{ℓobj ℓhom}}
    (factor : list C^.obj)
    (c : C^.obj)
    : Type (max ℓobj ℓhom)
:= dlist (λ x, C^.hom x c) factor

/-! #brief The nil HomsIn.
-/
definition HomsIn.nil {C : Cat.{ℓobj ℓhom}}
    {c : C^.obj}
    : HomsIn [] c
:= dlist.nil _

/-! #brief Push another hom onto a HomsIn.
-/
definition HomsIn.cons {C : Cat.{ℓobj ℓhom}}
    {x c : C^.obj} (f : C^.hom x c)
    {factor : list C^.obj} (tail : HomsIn factor c)
    : HomsIn (x :: factor) c
:= dlist.cons _ f _ tail

infixr `↗→` : 50 := HomsIn.cons
notation f `↗→↗` := HomsIn.cons f HomsIn.nil

/-! #brief Repeat a hom N times.
-/
definition HomsIn.repeat {C : Cat.{ℓobj ℓhom}}
    {x y : C^.obj}
    (f : C^.hom x y) (N : ℕ)
    : HomsIn (list.repeat x N) y
:= dlist.repeat f N

/-! #brief Converting a list of OverObj's into a HomsIn.
-/
definition HomsIn.of_list_OverObj {C : Cat.{ℓobj ℓhom}} {X : C^.obj}
    : ∀ (factors : list (OverObj C X))
      , HomsIn (list.map OverObj.dom factors) X
| [] := HomsIn.nil
| (O :: OO) := HomsIn.cons O^.hom (HomsIn.of_list_OverObj OO)

/-! #brief Composition with inward homs.
-/
definition HomsIn.comp {C : Cat.{ℓobj ℓhom}} {c₁ : C^.obj}
    {c₂ : C^.obj} (g : C^.hom c₁ c₂)
    {factor : list C^.obj}
    (proj : HomsIn factor c₁)
    : HomsIn factor c₂
:= dlist.map (λ a j, C^.circ g j) proj

/-! #brief HomsIn.comp distributes over composition of homs.
-/
definition HomsIn.comp_circ {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {c₁ c₂ : C^.obj} (g : C^.hom c₁ c₂) (f : C^.hom c c₁)
    {factor : list C^.obj}
    (proj : HomsIn factor c)
    : HomsIn.comp (C^.circ g f) proj
       = HomsIn.comp g (HomsIn.comp f proj)
:= begin
     unfold HomsIn.comp,
     apply eq.symm,
     refine eq.trans (dlist.map_map _ _) _,
     refine congr_arg (λ f, dlist.map f proj) _,
     apply funext, intro a, apply funext, intro j,
     apply C^.circ_assoc
   end

/-! #brief Composition of a HomsList with a HomsIn.
-/
definition homs_comp_in {C : Cat.{ℓobj ℓhom}}
    : ∀ {ccs : list (prod C^.obj C^.obj)}
        {c : C^.obj}
        (c_proj : HomsIn (list.map prod.snd ccs) c)
        (fns : HomsList C ccs)
      , HomsIn (list.map prod.fst ccs) c
:= λ ccs c c_proj fns
   , begin
       induction ccs with cc ccs rec,
       { apply dlist.nil },
       { cases fns with cc f ccs fns',
         cases cc with c₁ c₂,
         cases c_proj with c₁ p ccs c_proj',
         refine dlist.cons _ (C^.circ p f) _ (rec c_proj' fns')
       }
     end

/-! #brief Fetching a hom out of HomsIn.
-/
definition HomsIn.get {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj : HomsIn factor c)
    (n : fin (list.length factor))
    : C^.hom (list.get factor n) c
:= dlist.get proj n

/-! #brief get is injective.
-/
theorem HomsIn.get.inj {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj₁ proj₂ : HomsIn factor c)
    (ω : HomsIn.get proj₁ = HomsIn.get proj₂)
    : proj₁ = proj₂
:= dlist.get.inj ω

/-! #brief get on comp.
-/
theorem HomsIn.get_comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    {proj : HomsIn factor c}
    {c' : C^.obj} {g : C^.hom c c'}
    {n : fin (list.length factor)}
    : HomsIn.get (HomsIn.comp g proj) n = C^.circ g (HomsIn.get proj n)
:= dlist.get_map (λ (a : ⟦C⟧) (j : ⟦C : a →→ c⟧), @Cat.circ C _ _ _ g j) _ _

/-! #brief An inverse to HomsIn.get.
-/
definition HomsIn.enum {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (f : ∀ (n : fin (list.length factor)), C^.hom (list.get factor n) c)
    : HomsIn factor c
:= dlist.enum f

/-! #brief enum and get are inverses.
-/
theorem HomsIn.enum_get {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (proj : HomsIn factor c)
    : HomsIn.enum (HomsIn.get proj) = proj
:= dlist.enum_get

/-! #brief enum and get are inverses.
-/
theorem HomsIn.get_enum {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor : list C^.obj}
    (f : ∀ (n : fin (list.length factor)), C^.hom (list.get factor n) c)
    (n : fin (list.length factor))
    : HomsIn.get (HomsIn.enum f) n = f n
:= by apply @dlist.get_enum _ (λ x, C^.hom x c)

/-! #brief Appending lists of inward homs.
-/
definition HomsIn.append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsIn factor₁ c)
    (proj₂ : HomsIn factor₂ c)
    : HomsIn (factor₁ ++ factor₂) c
:= dlist.append proj₁ proj₂

/-! #brief Splitting lists of inward homs.
-/
definition HomsIn.split_left {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsIn (factor₁ ++ factor₂) c)
    : HomsIn factor₁ c
:= dlist.split_left factor₁ proj

/-! #brief Splitting lists of inward homs.
-/
definition HomsIn.split_right {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsIn (factor₁ ++ factor₂) c)
    : HomsIn factor₂ c
:= dlist.split_right factor₁ proj

/-! #brief Equality of HomsIn.append
-/
theorem HomsIn.append_eq {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ proj₂ : HomsIn (factor₁ ++ factor₂) c)
    (ωleft : HomsIn.split_left proj₁ = HomsIn.split_left proj₂)
    (ωright : HomsIn.split_right proj₁ = HomsIn.split_right proj₂)
    : proj₁ = proj₂
:= dlist.append_eq ωleft ωright

/-! #brief Action of split_left on append.
-/
theorem HomsIn.split_left_append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsIn factor₁ c)
    (proj₂ : HomsIn factor₂ c)
    : HomsIn.split_left (HomsIn.append proj₁ proj₂)
       = proj₁
:= dlist.split_left_append

/-! #brief Action of split_right on append.
-/
theorem HomsIn.split_right_append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsIn factor₁ c)
    (proj₂ : HomsIn factor₂ c)
    : HomsIn.split_right (HomsIn.append proj₁ proj₂)
       = proj₂
:= dlist.split_right_append

/-! #brief Action of split_left on comp.
-/
theorem HomsIn.split_left_comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsIn (factor₁ ++ factor₂) c)
    {c' : C^.obj} (f : C^.hom c c')
    : HomsIn.split_left (HomsIn.comp f proj)
       = HomsIn.comp f (HomsIn.split_left proj)
:= dlist.split_left_map _

/-! #brief Action of split_right on comp.
-/
theorem HomsIn.split_right_comp {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj : HomsIn (factor₁ ++ factor₂) c)
    {c' : C^.obj} (f : C^.hom c c')
    : HomsIn.split_right (HomsIn.comp f proj)
       = HomsIn.comp f (HomsIn.split_right proj)
:= dlist.split_right_map _

/-! #brief Action of get on an append.
-/
theorem HomsIn.get_append {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    (proj₁ : HomsIn factor₁ c)
    (proj₂ : HomsIn factor₂ c)
    (n : ℕ) (ωn : n < list.length factor₁)
    : HomsIn.get (HomsIn.append proj₁ proj₂) (fin.mk n (list.length.grow_left ωn))
       == HomsIn.get proj₁ (fin.mk n ωn)
:= by apply @dlist.get_append _ (λ x, C^.hom x c)

/-! #brief Action of get on split_left.
-/
theorem HomsIn.get_split_left {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    {proj : HomsIn (factor₁ ++ factor₂) c}
    {n : ℕ} {ωn : n < list.length factor₁}
    : HomsIn.get (HomsIn.split_left proj) (fin.mk n ωn)
       = HomsIn.get proj (fin.mk n (list.length.grow_left ωn))
          ∘∘ cast_hom (eq.symm list.get_append_left)
:= begin
     apply eq_of_heq,
     refine heq.trans _ (heq.symm (cast_hom.circ_right_heq _ _)),
     apply @dlist.get_split_left _ (λ x, C^.hom x c)
   end

/-! #brief Action of get on split_right.
-/
theorem HomsIn.get_split_right {C : Cat.{ℓobj ℓhom}} {c : C^.obj}
    {factor₁ factor₂ : list C^.obj}
    {proj : HomsIn (factor₁ ++ factor₂) c}
    {n : ℕ} {ωn : n < list.length factor₂}
    : HomsIn.get (HomsIn.split_right proj) (fin.mk n ωn)
       = HomsIn.get proj (fin.mk (n + list.length factor₁) (list.length.grow_right ωn))
          ∘∘ cast_hom (eq.symm list.get_append_right)
:= begin
     apply eq_of_heq,
     refine heq.trans _ (heq.symm (cast_hom.circ_right_heq _ _)),
     apply @dlist.get_split_right _ (λ x, C^.hom x c)
   end

/-! #brief Composition of a HomsIn with a HomsOut.
-/
definition homs_in_comp_out {C : Cat.{ℓobj ℓhom}}
    : ∀ {factor : list C^.obj}
        {c₁ c₂ : C^.obj}
        (hin : HomsIn factor c₂)
        (hout : HomsOut c₁ factor)
      , HomsList C (list.repeat (c₁, c₂) (list.length factor))
:= λ factor c₁ c₂ hin hout
   , begin
       induction factor with x factor rec,
       { apply dlist.nil },
       { cases hin with x fin factor hin',
         cases hout with x fout factor hout',
         refine dlist.cons _ (C^.circ fin fout) _ (rec hin' hout')
       }
     end

/-! #brief Action of get on homs_in_comp_out.
-/
theorem get_homs_in_comp_out {C : Cat.{ℓobj ℓhom}}
    {factor : list C^.obj}
    {c₁ c₂ : C^.obj}
    (hin : HomsIn factor c₂)
    (hout : HomsOut c₁ factor)
    {n : fin (list.length factor)}
    : HomsList.get (homs_in_comp_out hin hout) { val := n^.val, is_lt := begin rw list.length_repeat, exact n^.is_lt end }
       == C^.circ (HomsIn.get hin n) (HomsOut.get hout n)
:= begin
     induction factor with x factor rec,
     { exact fin.zero_elim n },
     { cases hin with x fin factor hin',
       cases hout with x fout factor hout',
       cases n with n ωn,
       cases n with n,
       { trivial },
       { refine @rec hin' hout' { val := n, is_lt := _ }}
     }
   end

end qp


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.finsupp
import algebra.monoid_algebra.support
import algebra.direct_sum.internal
import ring_theory.graded_algebra.basic

/-!
# Internal grading of an `add_monoid_algebra`

In this file, we show that an `add_monoid_algebra` has an internal direct sum structure.

## Main results

* `add_monoid_algebra.grade_by R f i`: the `i`th grade of an `add_monoid_algebra R M` given by the
  degree function `f`.
* `add_monoid_algebra.grade R i`: the `i`th grade of an `add_monoid_algebra R M` when the degree
  function is the identity.
* `add_monoid_algebra.grade_by.graded_algebra`: `add_monoid_algebra` is an algebra graded by
  `add_monoid_algebra.grade_by`.
* `add_monoid_algebra.grade.graded_algebra`: `add_monoid_algebra` is an algebra graded by
  `add_monoid_algebra.grade`.
* `add_monoid_algebra.grade_by.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade_by` defines an internal graded structure.
* `add_monoid_algebra.grade.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade` defines an internal graded structure when the degree function
  is the identity.
-/

noncomputable theory

namespace add_monoid_algebra
variables {M : Type*} {ι : Type*} {R : Type*} [decidable_eq M]

section
variables (R) [comm_semiring R]

/-- The submodule corresponding to each grade given by the degree function `f`. -/
abbreviation grade_by (f : M → ι) (i : ι) : submodule R (add_monoid_algebra R M) :=
{ carrier := {a | ∀ m, m ∈ a.support → f m = i },
  zero_mem' := set.empty_subset _,
  add_mem' := λ a b ha hb m h,
    or.rec_on (finset.mem_union.mp (finsupp.support_add h)) (ha m) (hb m),
  smul_mem' := λ a m h, set.subset.trans finsupp.support_smul h }

/-- The submodule corresponding to each grade. -/
abbreviation grade (m : M) : submodule R (add_monoid_algebra R M) := grade_by R id m

lemma grade_by_id : grade_by R (id : M → M) = grade R := by refl

lemma mem_grade_iff (m : M) (a : add_monoid_algebra R M) : a ∈ grade R m ↔ a.support ⊆ {m} :=
begin
  rw [← finset.coe_subset, finset.coe_singleton],
  refl
end

lemma mem_grade_iff' (m : M) (a : add_monoid_algebra R M) :
  a ∈ grade R m ↔
    a ∈ ((finsupp.lsingle m : R →ₗ[R] (M →₀ R)).range : submodule R (add_monoid_algebra R M)) :=
begin
  rw [mem_grade_iff, finsupp.support_subset_singleton'],
  apply exists_congr,
  intros r,
  split; exact eq.symm
end

lemma grade_eq_lsingle_range (m : M) : grade R m = (finsupp.lsingle m : R →ₗ[R] (M →₀ R)).range :=
submodule.ext (mem_grade_iff' R m)

lemma single_mem_grade_by {R} [comm_semiring R] (f : M → ι) (m : M) (r : R) :
  finsupp.single m r ∈ grade_by R f (f m) :=
begin
  intros x hx,
  rw finset.mem_singleton.mp (finsupp.support_single_subset hx),
end

lemma single_mem_grade {R} [comm_semiring R] (i : M) (r : R) : finsupp.single i r ∈ grade R i :=
single_mem_grade_by _ _ _

end

open_locale direct_sum

instance grade_by.graded_monoid [add_monoid M] [add_monoid ι] [comm_semiring R] (f : M →+ ι) :
  set_like.graded_monoid (grade_by R f : ι → submodule R (add_monoid_algebra R M)) :=
{ one_mem := λ m h, begin
    rw one_def at h,
    by_cases H : (1 : R) = (0 : R),
    { rw [H , finsupp.single_zero] at h,
      exfalso,
      exact h },
    { rw [finsupp.support_single_ne_zero _ H, finset.mem_singleton] at h,
      rw [h, add_monoid_hom.map_zero] }
  end,
  mul_mem := λ i j a b ha hb c hc, begin
    set h := support_mul a b hc,
    simp only [finset.mem_bUnion] at h,
    rcases h with ⟨ma, ⟨hma, ⟨mb, ⟨hmb, hmc⟩⟩⟩⟩,
    rw [← ha ma hma, ← hb mb hmb, finset.mem_singleton.mp hmc],
    apply add_monoid_hom.map_add
  end }

instance grade.graded_monoid [add_monoid M] [comm_semiring R] :
  set_like.graded_monoid (grade R : M → submodule R (add_monoid_algebra R M)) :=
by apply grade_by.graded_monoid (add_monoid_hom.id _)

variables {R} [add_monoid M] [decidable_eq ι] [add_monoid ι] [comm_semiring R] (f : M →+ ι)

/-- Auxiliary definition; the canonical grade decomposition, used to provide
`direct_sum.decompose`. -/
def decompose_aux : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i :=
add_monoid_algebra.lift R M _
{ to_fun := λ m, direct_sum.of (λ i : ι, grade_by R f i) (f m.to_add)
    ⟨finsupp.single m.to_add 1, single_mem_grade_by _ _ _⟩,
  map_one' := direct_sum.of_eq_of_graded_monoid_eq (by congr' 2; try {ext};
    simp only [submodule.mem_to_add_submonoid, to_add_one, add_monoid_hom.map_zero]),
  map_mul' := λ i j, begin
    symmetry,
    convert direct_sum.of_mul_of _ _,
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2,
    { rw [to_add_mul, add_monoid_hom.map_add] },
    { ext,
      simp only [submodule.mem_to_add_submonoid, add_monoid_hom.map_add, to_add_mul] },
    { exact eq.trans (by rw [one_mul, to_add_mul]) single_mul_single.symm }
  end }

lemma decompose_aux_single (m : M) (r : R) :
  decompose_aux f (finsupp.single m r) =
    direct_sum.of (λ i : ι, grade_by R f i) (f m)
      ⟨finsupp.single m r, single_mem_grade_by _ _ _⟩ :=
begin
  refine (lift_single _ _ _).trans _,
  refine (direct_sum.of_smul _ _ _ _).symm.trans _,
  apply direct_sum.of_eq_of_graded_monoid_eq,
  refine sigma.subtype_ext rfl _,
  refine (finsupp.smul_single' _ _ _).trans _,
  rw mul_one,
  refl,
end

lemma decompose_aux_coe {i : ι} (x : grade_by R f i) :
  decompose_aux f ↑x = direct_sum.of (λ i, grade_by R f i) i x :=
begin
  obtain ⟨x, hx⟩ := x,
  revert hx,
  refine finsupp.induction x _ _,
  { intros hx,
    symmetry,
    exact add_monoid_hom.map_zero _ },
  { intros m b y hmy hb ih hmby,
    have : disjoint (finsupp.single m b).support y.support,
    { simpa only [finsupp.support_single_ne_zero _ hb, finset.disjoint_singleton_left] },
    rw [mem_grade_by_iff, finsupp.support_add_eq this, finset.coe_union,
      set.union_subset_iff] at hmby,
    cases hmby with h1 h2,
    have : f m = i,
    { rwa [finsupp.support_single_ne_zero _ hb, finset.coe_singleton,
        set.singleton_subset_iff] at h1 },
    subst this,
    simp only [alg_hom.map_add, submodule.coe_mk, decompose_aux_single f m],
    let ih' := ih h2,
    dsimp at ih',
    rw [ih', ← add_monoid_hom.map_add],
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2 }
end

instance grade_by.graded_algebra : graded_algebra (grade_by R f) :=
graded_algebra.of_alg_hom _
  (decompose_aux f)
  (begin
    ext : 2,
    simp only [alg_hom.coe_to_monoid_hom, function.comp_app, alg_hom.coe_comp,
        function.comp.left_id, alg_hom.coe_id, add_monoid_algebra.of_apply, monoid_hom.coe_comp],
    rw [decompose_aux_single, direct_sum.coe_alg_hom_of, subtype.coe_mk],
  end)
  (λ i x, by rw [decompose_aux_coe f x])

-- Lean can't find this later without us repeating it
instance grade_by.decomposition : direct_sum.decomposition (grade_by R f) :=
by apply_instance

@[simp] lemma decompose_aux_eq_decompose :
  ⇑(decompose_aux f : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i) =
    (direct_sum.decompose (grade_by R f)) := rfl

@[simp] lemma grades_by.decompose_single (m : M) (r : R) :
  direct_sum.decompose (grade_by R f) (finsupp.single m r : add_monoid_algebra R M) =
    direct_sum.of (λ i : ι, grade_by R f i) (f m)
      ⟨finsupp.single m r, single_mem_grade_by _ _ _⟩ :=
decompose_aux_single _ _ _

instance grade.graded_algebra : graded_algebra (grade R : ι → submodule _ _) :=
add_monoid_algebra.grade_by.graded_algebra (add_monoid_hom.id _)

-- Lean can't find this later without us repeating it
instance grade.decomposition : direct_sum.decomposition (grade R : ι → submodule _ _) :=
by apply_instance

@[simp]
lemma grade.decompose_single (i : ι) (r : R) :
  direct_sum.decompose (grade R : ι → submodule _ _) (finsupp.single i r : add_monoid_algebra _ _) =
    direct_sum.of (λ i : ι, grade R i) i ⟨finsupp.single i r, single_mem_grade _ _⟩ :=
decompose_aux_single _ _ _

/-- `add_monoid_algebra.gradesby` describe an internally graded algebra -/
lemma grade_by.is_internal : direct_sum.is_internal (grade_by R f) :=
direct_sum.decomposition.is_internal _

/-- `add_monoid_algebra.grades` describe an internally graded algebra -/
lemma grade.is_internal : direct_sum.is_internal (grade R : ι → submodule R _) :=
direct_sum.decomposition.is_internal _

end add_monoid_algebra