import data.vector
import data.equiv.denumerable
import data.list.sort
import ring_theory.tensor_product
import algebra.category.Module.basic

@[derive decidable_eq] inductive type (cT : Type) : Type
| const : cT → type
| arrow : type → type → type
| tensor : type → type → type

variables (cT : Type)

@[reducible] def context (cT : Type) : Type := list (string × type cT)

notation a ` ++' ` b := list.append b a

notation a ` ::' ` b := list.cons b a

variables {cT}

inductive term (const_term : type cT → Type) : Π (Γ : context cT) (A : type cT), Type
| const {T : type cT} (t : const_term T) : term [] T
| var (a : string) (T : type cT) : term [(a, T)] T
| app (Γ₁ Γ₂ : context cT) {T₁ T₂ : type cT} (f : term Γ₁ (T₁.arrow T₂)) (x : term Γ₂ T₁) :
    term (Γ₁ ++' Γ₂) T₂
| lambda {Γ : context cT} (a : string) (T₁ : type cT) {T₂ : type cT}
    (t : term (Γ ::' (a, T₁)) T₂) : term Γ (T₁.arrow T₂)

open category_theory

variables {R : Type} [comm_ring R]

section

variables (cTi : cT → Module.{0 0} R)

open_locale tensor_product

def typei : type cT → Module R
| (type.const T)     := cTi T
| (type.arrow T₁ T₂) := Module.of R (typei T₁ →ₗ[R] typei T₂)
| (type.tensor T₁ T₂) := Module.of R (typei T₁ ⊗[R] typei T₂)

def contexti : context cT → Module R
| []       := Module.of R R
| (T :: l) := Module.of R (contexti l ⊗[R] typei cTi T.2 )

def contexti_append : Π (Γ₁ Γ₂ : context cT),
  (contexti cTi (Γ₁ ++' Γ₂)) ≃ₗ[R] contexti cTi Γ₁ ⊗[R] contexti cTi Γ₂
| Γ₁      [] := (tensor_product.rid R (contexti cTi Γ₁)).symm
| Γ₁ (A::Γ₂) := (tensor_product.congr
    (contexti_append Γ₁ Γ₂) (linear_equiv.refl R (typei cTi A.2))).trans
  (tensor_product.assoc R _ _ _)

variables {const_term : type cT → Type}
variables (const_termi : Π {T : type cT}, const_term T → typei cTi T)

def termi : Π {Γ : context cT} {A : type cT} (t : term const_term Γ A),
  contexti cTi Γ →ₗ[R] typei cTi A
| _ A (term.const t) := linear_map.to_span_singleton _ _ (const_termi t)
| _ _ (term.var _ A) := (tensor_product.lid _ _).to_linear_map
| _ T₂ (@term.app  _ _ Γ₁ Γ₂ T₁ _ f x) :=
  linear_map.comp (tensor_product.uncurry R (contexti cTi Γ₁) (contexti cTi Γ₂) _
       (linear_map.comp (linear_map.lcomp R _ (termi x)) (termi f)))
     (contexti_append _ Γ₁ Γ₂).to_linear_map
| Γ (type.arrow _ T₂) (term.lambda a T₁ t) := tensor_product.curry (termi t)

end

variables {M : Module.{0 0} R} (op : M →ₗ[R] M →ₗ[R] M)

open term

def const_term : type unit → Type
| (type.arrow (type.const ()) (type.arrow (type.const ()) (type.const ()))) := unit
| _ := empty

def cTi : unit → Module R := λ _, M

include op

def const_termi {T : type unit} (t : const_term T) : typei (@cTi R _ M) T :=
begin
  cases T with _ T₁ T₂; try { apply empty.elim t },
  cases T₁ with _ T₂ T₃; try { apply empty.elim t },
  cases T₁,
  cases T₂ with _ T₁ T₂; try { apply empty.elim t },
  cases T₁ with _ T₁ T₂; try { apply empty.elim t },
  cases T₁,
  cases T₂ with _ T₁ T₂; try { apply empty.elim t },
  exact op
end

omit op

def mult : const_term (type.arrow (type.const ()) (type.arrow (type.const ()) (type.const ()))) := ()

notation `T` := type.const ()

def exmpl₁ : @term unit const_term []
  ((type.const ()).arrow ((type.const ()).arrow ((type.const ()).arrow (type.const ())))) :=
lambda "a" T $
lambda "b" T $
lambda "c" T $
  app [("b", T), ("a", T)] [("c", T)]
  (app [] [("b", T), ("a", T)] (const mult)
    (app [("a", T)] [("b", T)]
      (app [] [("a", T)] (const mult) (var "a" (type.const ())))
        (var "b" (type.const ()))) : _)
    (var "c" (type.const ()))

example (p q r : M) :
  termi (@cTi R _ M) (@const_termi _ _ _ op) exmpl₁ = sorry :=
begin
  dunfold exmpl₁,
  simp[termi, contexti],
  dsimp [typei, contexti, contexti_append, cTi, const_termi],
  ext,
  simp,

end


/-
Copyright (c) 2020 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Alexander Bentkamp.
-/

import ring_theory.principal_ideal_domain
import missing_mathlib.data.polynomial
import missing_mathlib.data.multiset
import missing_mathlib.data.finsupp
import missing_mathlib.linear_algebra.dimension
import missing_mathlib.linear_algebra.finite_dimensional
import missing_mathlib.linear_algebra.finsupp
import missing_mathlib.algebra.group.units
import missing_mathlib.algebra.ring
import missing_mathlib.algebra.module
import missing_mathlib.algebra.group_power
import missing_mathlib.data.list.basic
import missing_mathlib.set_theory.cardinal
import missing_mathlib.ring_theory.algebra
import missing_mathlib.ring_theory.polynomial.basic
import analysis.complex.polynomial
import missing_mathlib.field_thoery.algebraic_closure

/-!
# Eigenvectors and eigenvalues

This file defines eigenvectors and eigenvalues, as well as generalized
eigenvectors and eigenvalues.

An eigenvector of a linear map `f` is a nonzero vector `x` such that `f x = μ • x`
for some scalar `μ`. The scalar `μ` is called an eigenvalue. We express this
by writing `eigenvector f μ x`.

A generalized eigenvector of a linear map `f` is a nonzero vector `x` such that
`(f x - μ • x) ^ k = 0` for some scalar `μ` and some natural number `k`. The
scalar `μ` is called a generalized eigenvalue. We express this
by writing `generalized_eigenvector f k μ x`.

We follow Axler's approach [axler1996] that allows us to prove a lot of
properties of eigenvectors without choosing a basis, without determinants and
without matrices. We deviate from his definitions by defining 0 not to be an
eigenvector, which seems to be the more common convention.

## Notations

The expression `algebra_map α (β →ₗ[α] β)` appears very often, which is why we
use `am` as a local notation for it.

## References

* [Sheldon Axler, *Down with determinants!*,
  https://www.maa.org/sites/default/files/pdf/awards/Axler-Ford-1996.pdf][axler1996]
* https://en.wikipedia.org/wiki/Eigenvalues_and_eigenvectors

## Tags

eigenvector, eigenvalues, eigen
-/

universes u v w

open vector_space principal_ideal_ring polynomial finite_dimensional

variables {α : Type v} {β : Type w} [decidable_eq β] [add_comm_group β]

/-- An eigenvector of a linear map `f` with eigenvalue `μ` is a nonzero vector
    `x` such that `f x = μ • x`. -/
def eigenvector [field α] [vector_space α β]
  (f : β →ₗ[α] β) (μ : α) (x : β) : Prop := x ≠ 0 ∧ f x = μ • x

local notation `am` := algebra_map α (β →ₗ[α] β)

/-- Every linear operator on a vector space over an algebraically closed field has
    an eigenvalue. (Axler's Theorem 2.1.) -/
lemma exists_eigenvector
  [field α] [is_alg_closed α] [decidable_eq α] [vector_space α β] [finite_dimensional α β]
  (f : β →ₗ[α] β) (hex : ∃ v : β, v ≠ 0) :
  ∃ (x : β) (c : α), eigenvector f c x :=
begin
  obtain ⟨v, hv⟩ : ∃ v : β, v ≠ 0 := hex,
  have h_lin_dep : ¬ linear_independent α (λ n : ℕ, (f ^ n) v),
  { intro h_lin_indep,
    have : cardinal.mk ℕ < cardinal.omega,
      by apply (lt_omega_of_linear_independent h_lin_indep),
    have := cardinal.lift_lt.2 this,
    rw [cardinal.omega, cardinal.lift_lift] at this,
    apply lt_irrefl _ this, },
  haveI := classical.dec (∃ (x : polynomial α), ¬(polynomial.eval₂ am f x v = 0 → x = 0)),
  obtain ⟨p, hp⟩ : ∃ p, ¬(eval₂ am f p v = 0 → p = 0),
  { exact not_forall.1 (λ h, h_lin_dep ((linear_independent_iff_eval₂ f v).2 h)) },
  obtain ⟨h_eval_p, h_p_ne_0⟩ : eval₂ am f p v = 0 ∧ p ≠ 0 := not_imp.1 hp,
  obtain ⟨q, hq_mem, hq_noninj⟩ : ∃ q ∈ factors p, ¬function.injective ⇑(eval₂ am f q),
  { exact polynomial.exists_noninjective_factor_of_eval₂_0 f v hv p h_p_ne_0 h_eval_p },
  have h_q_ne_0 : q ≠ 0 := ne_0_of_mem_factors h_p_ne_0 hq_mem,
  have h_deg_q : q.degree = 1 := is_alg_closed.degree_eq_one_of_irreducible _ h_q_ne_0
    ((factors_spec p h_p_ne_0).1 q hq_mem),
  have h_q_eval₂ : polynomial.eval₂ am f q = q.leading_coeff • f + am (q.coeff 0),
  { rw [polynomial.eq_X_add_C_of_degree_eq_one h_deg_q],
    simp [eval₂_mul_noncomm am f _ _ (λ x y, ( algebra.commutes' x y).symm)],
    simp [leading_coeff_X_add_C _ _ (λ h, h_q_ne_0 (leading_coeff_eq_zero.1 h))],
    refl },
  obtain ⟨x, hx₁, hx₂⟩ : ∃ (x : β), eval₂ am f q x = 0 ∧ ¬x = 0,
  { rw [←linear_map.ker_eq_bot, linear_map.ker_eq_bot', classical.not_forall] at hq_noninj,
    simpa only [not_imp] using hq_noninj },
  have h_fx_x_lin_dep: leading_coeff q • f x + coeff q 0 • x = 0,
  { rw h_q_eval₂ at hx₁,
    exact hx₁ },
  show ∃ (x : β) (c : α), x ≠ 0 ∧ f x = c • x,
  { use x,
    use -(coeff q 0 / q.leading_coeff),
    refine ⟨hx₂, _⟩,
    rw neg_smul,
    have : (leading_coeff q)⁻¹ • leading_coeff q • f x = (leading_coeff q)⁻¹ • -(coeff q 0 • x) :=
      congr_arg (λ x, (leading_coeff q)⁻¹ • x) (add_eq_zero_iff_eq_neg.1 h_fx_x_lin_dep),
    simpa [smul_smul, inv_mul_cancel (λ h, h_q_ne_0 (leading_coeff_eq_zero.1 h)),
      mul_comm _ (coeff q 0), div_eq_mul_inv.symm] }
end

/-- Eigenvectors corresponding to distinct eigenvalues of a linear operator are
    linearly independent (Axler's Proposition 2.2) -/
lemma eigenvectors_linear_independent [field α] [decidable_eq α] [vector_space α β]
  (f : β →ₗ[α] β) (μs : set α) (xs : μs → β) (h_eigenvec : ∀ μ : μs, eigenvector f μ (xs μ)):
  linear_independent α xs :=
begin
  rw linear_independent_iff,
  intros l hl,
  induction h_l_support : l.support using finset.induction with μ₀ l_support' hμ₀ ih generalizing l,
  { exact finsupp.support_eq_empty.1 h_l_support },
  { let l'_f := (λ μ : μs, (↑μ - ↑μ₀) * l μ),
    have h_l_support' : ∀ (μ : μs), l'_f μ ≠ 0 ↔ μ ∈ l_support',
    { intros μ,
      dsimp only [l'_f],
      rw [mul_ne_zero_iff, sub_ne_zero, ←not_iff_not, not_and_distrib, not_not, not_not, ←subtype.ext_iff],
      split,
      { intro h,
        cases h,
        { rwa h },
        { intro h_mem_l_support',
          apply finsupp.mem_support_iff.1 _ h,
          rw h_l_support,
          apply finset.subset_insert _ _ h_mem_l_support' } },
      { intro h,
        apply (@or_iff_not_imp_right _ _ (classical.dec _)).2,
        intro hlμ,
        have := finsupp.mem_support_iff.2 hlμ,
        rw [h_l_support, finset.mem_insert] at this,
        cc } },
    let l' : μs →₀ α := finsupp.on_finset l_support' l'_f (λ μ, (h_l_support' μ).1),
    have total_l' : (@linear_map.to_fun α (finsupp μs α) β _ _ _ _ _ (finsupp.total μs β α xs)) l' = 0,
    { let g := f - am μ₀,
      have h_gμ₀: g (l μ₀ • xs μ₀) = 0,
        by rw [linear_map.map_smul, linear_map.sub_apply, (h_eigenvec _).2, module.endomorphism_algebra_map_apply2, sub_self, smul_zero],
      have h_useless_filter : finset.filter (λ (a : μs), l'_f a ≠ 0) l_support' = l_support',
      { convert @finset.filter_congr _ _ _ (classical.dec_pred _) (classical.dec_pred _) _ _,
        { apply finset.filter_true.symm },
        exact λ μ hμ, iff_of_true ((h_l_support' μ).2 hμ) true.intro },
      have bodies_eq : ∀ (μ : μs), l'_f μ • xs μ = g (l μ • xs μ),
      { intro μ,
        dsimp only [g, l'_f],
        rw [linear_map.map_smul, linear_map.sub_apply, (h_eigenvec _).2, module.endomorphism_algebra_map_apply2, ←sub_smul, smul_smul, mul_comm] },
      have := finsupp.total_on_finset l_support' l'_f xs _,
      unfold_coes at this,
      rw [this, ←linear_map.map_zero g,
          ←congr_arg g hl, finsupp.total_apply, finsupp.sum, linear_map.map_sum, h_l_support,
          finset.sum_insert hμ₀, h_gμ₀, zero_add, h_useless_filter],
      simp only [bodies_eq] },
    have h_l'_support_eq : l'.support = l_support',
    { dsimp only [l'],
      ext μ,
      rw finsupp.on_finset_mem_support l_support' l'_f _ μ,
      by_cases h_cases: μ ∈ l_support',
      { refine iff_of_true _ h_cases,
        exact (h_l_support' μ).2 h_cases },
      { refine iff_of_false _ h_cases,
        rwa not_iff_not.2 (h_l_support' μ) } },
    have l'_eq_0 : l' = 0 := ih l' total_l' h_l'_support_eq,

    have h_mul_eq_0 : ∀ μ : μs, (↑μ - ↑μ₀) * l μ = 0,
    { intro μ,
      calc (↑μ - ↑μ₀) * l μ = l' μ : rfl
      ... = 0 : by { rw [l'_eq_0], refl } },

    have h_lμ_eq_0 : ∀ μ : μs, μ ≠ μ₀ → l μ = 0,
    { intros μ hμ,
      apply classical.or_iff_not_imp_left.1 (mul_eq_zero.1 (h_mul_eq_0 μ)),
      rwa [sub_eq_zero, ←subtype.ext_iff] },

    have h_sum_l_support'_eq_0 : finset.sum l_support' (λ (μ : ↥μs), l μ • xs μ) = 0,
    { rw ←finset.sum_const_zero,
      apply finset.sum_congr rfl,
      intros μ hμ,
      rw h_lμ_eq_0,
      apply zero_smul,
      intro h,
      rw h at hμ,
      contradiction },

    have : l μ₀ = 0,
    { rw [finsupp.total_apply, finsupp.sum, h_l_support,
          finset.sum_insert hμ₀, h_sum_l_support'_eq_0, add_zero] at hl,
      by_contra h,
      exact (h_eigenvec μ₀).1 ((vector_space.smul_neq_zero (xs μ₀) h).1 hl) },

    show l = 0,
    { ext μ,
      by_cases h_cases : μ = μ₀,
      { rw h_cases,
        assumption },
      exact h_lμ_eq_0 μ h_cases } }
end

/-- A generalized eigenvector (also called eventual eigenvector) of a linear map
    $f$ is a nonzero vector $x$ such that $(f - \mu I) ^ k) x = 0$ for some
    scalar $\mu$ and some natural number $k$ (where $I$ is the identity map).

    We deviate from Axler's definition by requiring that $x$ is nonzero, which
    implies that $k$ is nonzero, too. -/
def generalized_eigenvector [field α] [vector_space α β]
  (f : β →ₗ[α] β) (k : ℕ) (μ : α) (x : β) : Prop := x ≠ 0 ∧ ((f - am μ) ^ k) x = 0

/-- The natural number of a generalized eigenvector is never 0. -/
lemma exp_ne_zero_of_generalized_eigenvector_ne_zero [field α] [vector_space α β]
  {f : β →ₗ[α] β} {k : ℕ} {μ : α} {x : β} (h : generalized_eigenvector f k μ x) :
  k ≠ 0 :=
begin
  rcases h with ⟨h_nz, h⟩,
  contrapose h_nz,
  rw not_not at h_nz ⊢,
  rwa [h_nz, pow_zero] at h
end

/-- A generalized eigenvector for some number `k` is also a generalized
    eigenvector for number larger than `k`. -/
lemma generalized_eigenvector_zero_beyond [field α] [vector_space α β]
  {f : β →ₗ[α] β} {k : ℕ} {μ : α} {x : β} (h : generalized_eigenvector f k μ x) :
  ∀ m : ℕ, k ≤ m → generalized_eigenvector f m μ x :=
begin
  intros m hm,
  refine ⟨h.1, _⟩,
  rw ←pow_eq_pow_sub_mul _ hm,
  change ((f - am μ) ^ (m - k)) (((f - am μ) ^ k) x) = 0,
  unfold generalized_eigenvector at h,
  rw [h.2, linear_map.map_zero]
end

/-- All eigenvectors are generalized eigenvectors. -/
lemma generalized_eigenvector_of_eigenvector [field α] [vector_space α β]
  {f : β →ₗ[α] β} {k : ℕ} {μ : α} {x : β} (hx : eigenvector f μ x) (hk : k > 0) :
  generalized_eigenvector f k μ x :=
begin
  rw [generalized_eigenvector, ←nat.succ_pred_eq_of_pos hk, pow_succ'],
  change x ≠ 0 ∧ ((f - am μ) ^ nat.pred k) ((f - am μ) x) = 0,
  have : (f - am μ) x = 0 := by simp [hx.2, module.endomorphism_algebra_map_apply2],
  simp [this, hx.1]
end

/-- The set of generalized eigenvectors of f corresponding to an eigenvalue μ
    equals the kernel of (f - am μ) ^ n, where n is the dimension of
    the vector space (Axler's Lemma 3.1). -/
lemma generalized_eigenvector_dim
  [field α] [decidable_eq α] [vector_space α β] [finite_dimensional α β]
  (f : β →ₗ[α] β) (μ : α) (x : β) :
  (∃ k : ℕ, generalized_eigenvector f k μ x)
    ↔ generalized_eigenvector f (findim α β) μ x :=
begin
  split,
  { show (∃ (k : ℕ), generalized_eigenvector f k μ x) → x ≠ 0 ∧ ((f - am μ) ^ findim α β) x = 0,
    intro h_exists_eigenvec,
    let k := @nat.find (λ k : ℕ, generalized_eigenvector f k μ x) (classical.dec_pred _) h_exists_eigenvec,
    let z := (λ i : fin k, ((f - am μ) ^ (i : ℕ)) x),

    have h_x_nz : x ≠ 0,
    { rcases h_exists_eigenvec with ⟨k, h⟩,
      exact h.1 },

    have h_lin_indep : linear_independent α z,
    { rw linear_independent_iff,
      intros l hl,
      ext i,
      induction h_i_val : i.val using nat.strong_induction_on with i_val ih generalizing i,
      simp only [h_i_val.symm] at *,
      clear h_i_val i_val,

      have h_zero_of_lt : ∀ j, j < i → ((f - am μ) ^ (k - i.val - 1)) (l j • z j) = 0,
      { intros j hj,
        simp [ih j hj j rfl] },

      have h_zero_beyond_k : ∀ m, k ≤ m → ((f - am μ) ^ m) x = 0,
      { intros m hm,
        apply (generalized_eigenvector_zero_beyond
            (@nat.find_spec (λ k : ℕ, generalized_eigenvector f k μ x) (classical.dec_pred _) h_exists_eigenvec) _ hm).2 },

      have h_zero_of_gt : ∀ j, j > i → ((f - am μ) ^ (k - i.val - 1)) (l j • z j) = 0,
      { intros j hj,
        dsimp only [z],
        rw [linear_map.map_smul],
        change l j • ((f - am μ) ^ (k - i.val - 1) * ((f - am μ) ^ ↑j)) x = 0,
        rw [←pow_add, h_zero_beyond_k, smul_zero],
        rw [nat.sub_sub, ←nat.sub_add_comm (nat.succ_le_of_lt i.2)],
        apply nat.le_sub_right_of_add_le,
        apply nat.add_le_add_left,
        rw ←nat.lt_iff_add_one_le,
        unfold_coes,
        change i.val < (j : ℕ),
        exact hj },

      have h_zero_of_ne : ∀ j, j ≠ i → ((f - am μ) ^ (k - i.val - 1)) (l j • z j) = 0,
      { intros j hj,
        cases lt_or_gt_of_ne hj with h_lt h_gt,
        apply h_zero_of_lt j h_lt,
        apply h_zero_of_gt j h_gt },

      have h_zero_of_not_support : i ∉ l.support → ((f - am μ) ^ (k - i.val - 1)) (l i • z i) = 0,
      { intros hi,
        rw [finsupp.mem_support_iff, not_not] at hi,
        rw [hi, zero_smul, linear_map.map_zero] },

      have h_l_smul_pow_k_sub_1 : l i • (((f - am μ) ^ (k - 1)) x) = 0,
      { have h_k_sub_1 : k - i.val - 1 + i.val = k - 1,
        { rw ←nat.sub_add_comm,
          { rw nat.sub_add_cancel,
            apply le_of_lt i.2 },
          { apply nat.le_sub_left_of_add_le,
            apply nat.succ_le_of_lt i.2 } },
        rw [←h_k_sub_1, pow_add],
        let g := (f - am μ) ^ (k - i.val - 1),
        rw [finsupp.total_apply, finsupp.sum] at hl,
        have := congr_arg g hl,
        rw [linear_map.map_sum, linear_map.map_zero g] at this,
        dsimp only [g] at this,
        rw finset.sum_eq_single i (λ j _, h_zero_of_ne j) h_zero_of_not_support at this,
        simp only [linear_map.map_smul, z] at this,
        apply this },

      have h_pow_k_sub_1 : ((f - am μ) ^ (k - 1)) x ≠ 0 :=
        not_and.1 (@nat.find_min (λ k : ℕ, generalized_eigenvector f k μ x) (classical.dec_pred _) h_exists_eigenvec _
            (nat.sub_lt (nat.lt_of_le_of_lt (nat.zero_le _) i.2) nat.zero_lt_one)) h_x_nz,

      show l i = 0,
      { contrapose h_pow_k_sub_1 with h_li_ne_0,
        rw not_not,
        apply (vector_space.smul_neq_zero _ h_li_ne_0).1,
        apply h_l_smul_pow_k_sub_1 } },

    show x ≠ 0 ∧ ((f - am μ) ^ findim α β) x = 0,
    { split,
      { exact h_x_nz },
      apply (generalized_eigenvector_zero_beyond
        (@nat.find_spec (λ k : ℕ, generalized_eigenvector f k μ x) (classical.dec_pred _) h_exists_eigenvec) _ _).2,
      rw [←cardinal.nat_cast_le, ←cardinal.lift_mk_fin _, ←cardinal.lift_le, cardinal.lift_lift],
      rw findim_eq_dim,
      apply h_lin_indep.le_lift_dim} },

  { show generalized_eigenvector f (findim α β) μ x → (∃ (k : ℕ), generalized_eigenvector f k μ x),
    exact λh, ⟨_, h⟩, }
end

lemma generalized_eigenvector_restrict_aux [field α] [vector_space α β]
  (f : β →ₗ[α] β) (p : submodule α β) (k : ℕ) (μ : α) (x : p)
  (hfp : ∀ (x : β), x ∈ p → f x ∈ p) :
  (((f.restrict p p hfp - algebra_map _ _ μ) ^ k) x : β)
  = ((f - algebra_map _ _ μ) ^ k) x :=
begin
  induction k with k ih,
  { rw [pow_zero, pow_zero, linear_map.one_app, linear_map.one_app] },
  { rw [pow_succ, pow_succ],
    change ((f.restrict p p hfp - algebra_map _ _ μ) (((f.restrict p p hfp - algebra_map _ _ μ) ^ k) x) : β) =
        (f - algebra_map _ _ μ) (((f - algebra_map _ _ μ) ^ k) x),
    rw [linear_map.sub_apply, linear_map.sub_apply, linear_map.restrict_apply, ←ih],
    refl }
end

/-- If `f` maps a subspace `p` into itself, then the generalized eigenvectors of
    `f` restricted to `p` are the generalized eigenvectors of `f` that lie in
    `p`.
-/
lemma generalized_eigenvector_restrict [field α] [vector_space α β]
  (f : β →ₗ[α] β) (p : submodule α β) (k : ℕ) (μ : α) (x : p) (hfp : ∀ (x : β), x ∈ p → f x ∈ p) :
  generalized_eigenvector (linear_map.restrict f p p hfp) k μ x
    ↔ generalized_eigenvector f k μ x :=
begin
  rw [generalized_eigenvector, subtype.ext_iff,  generalized_eigenvector_restrict_aux],
  simp [generalized_eigenvector]
end

/-- If a vector is a generalized eigenvector for some number `k`, then it is
    also a generalized eigenvector for the dimension of the vector space. -/
lemma generalized_eigenvector_dim_of_any
  [field α] [decidable_eq α] [vector_space α β] [finite_dimensional α β]
  {f : β →ₗ[α] β} {μ : α}
  {k : ℕ} {x : β} (h : generalized_eigenvector f k μ x) :
  generalized_eigenvector f (findim α β) μ x :=
begin
  rw ←generalized_eigenvector_dim,
  { exact ⟨k, h⟩ }
end

/-- Kernel and range of $(f - \mu I) ^ n$ are disjoint, where $f$ is a linear
    map, $\mu$ is a scalar, $I$ is the identity matrix, and $n$ is the dimension of
    the vector space. -/
lemma generalized_eigenvec_disjoint_range_ker
  [field α] [decidable_eq α] [vector_space α β] [finite_dimensional α β]
  (f : β →ₗ[α] β) (μ : α) :
  disjoint ((f - am μ) ^ findim α β).range ((f - am μ) ^ findim α β).ker :=
begin
  rintros v ⟨⟨u, _, hu⟩, hv⟩,
  have h2n : ((f - am μ) ^ (findim α β + findim α β)) u = 0,
  { rw [pow_add, ←linear_map.mem_ker.1 hv, ←hu], refl },
  have hn : ((f - am μ) ^ findim α β) u = 0,
  { by_cases h_cases: u = 0,
    { simp [h_cases] },
    { apply (generalized_eigenvector_dim_of_any ⟨h_cases, h2n⟩).2 } },
  have hv0 : v = 0, by rw [←hn, hu],
  show v ∈ ↑⊥, by simp [hv0]
end

/-- The kernel of $(f - \mu I) ^ k$ for $k > 0$ has positive dimension if $\mu$
    is an eigenvalue. -/
lemma pos_dim_eigenker_of_eigenvec [field α] [is_alg_closed α] [vector_space α β]
  {f : β →ₗ[α] β} {n : ℕ} {μ : α} {x : β} (hx : eigenvector f μ x) :
  0 < dim α ((f - am μ) ^ n.succ).ker :=
begin
  have x_mem : x ∈ ((f - am μ) ^ n.succ).ker,
  { simp [pow_succ', hx.2, module.endomorphism_algebra_map_apply2] },
  apply dim_pos_of_mem_ne_zero (⟨x, x_mem⟩ : ((f - am μ) ^ n.succ).ker),
  intros h,
  apply hx.1,
  exact congr_arg subtype.val h,
end

/-- Variant of `pos_dim_eigenker_of_eigenvec` for finite dimensional vector spaces. -/
lemma pos_findim_eigenker_of_eigenvec
  [field α] [is_alg_closed α] [vector_space α β] [finite_dimensional α β]
  {f : β →ₗ[α] β} {n : ℕ} {μ : α} {x : β} (hx : eigenvector f μ x) :
  0 < findim α ((f - am μ) ^ n.succ).ker :=
begin
  apply cardinal.nat_cast_lt.1,
  rw findim_eq_dim,
  apply pos_dim_eigenker_of_eigenvec hx,
end

/-- The kernel of $(f - \mu I) ^ k$ is contained in the span of all generalized eigenvectors. -/
lemma eigenker_le_span_gen_eigenvec [field α] [vector_space α β]
  (f : β →ₗ[α] β) (μ₀ : α) (n : ℕ) :
((f - am μ₀) ^ n).ker
  ≤ submodule.span α ({x : β | ∃ (k : ℕ) (μ : α), generalized_eigenvector f k μ x}) :=
begin
  intros x hx,
  by_cases h_cases: x = 0,
  { simp [h_cases] },
  { apply submodule.subset_span,
    exact ⟨n, μ₀, h_cases, linear_map.mem_ker.1 hx⟩ }
end

/-- If $x$ is in the range of $(f - \mu I) ^ k$, then so is $f(x)$. -/
lemma image_mem_eigenrange_of_mem_eigenrange [field α] [vector_space α β]
  {f : β →ₗ[α] β} {μ : α} {x : β} {n : ℕ}
  (hx : x ∈ ((f - am μ) ^ n).range) :
  f x ∈ ((f - am μ) ^ n).range :=
begin
  rw linear_map.mem_range at *,
  rcases hx with ⟨w, hw⟩,
  use f w,
  have hcommutes : f.comp ((f - am μ) ^ n) = ((f - am μ) ^ n).comp f :=
    algebra.mul_sub_algebra_map_pow_commutes f μ n,
  rw [←linear_map.comp_apply, ←hcommutes, linear_map.comp_apply, hw],
end

/-- The generalized eigenvectors of f span the vectorspace β. (Axler's Proposition 3.4). -/
lemma generalized_eigenvector_span
  [field α] [is_alg_closed α] [decidable_eq α] [vector_space α β] [finite_dimensional α β]
  (f : β →ₗ[α] β) :
  submodule.span α {x | ∃ k μ, generalized_eigenvector f k μ x} = ⊤ :=
begin
  rw ←top_le_iff,
  tactic.unfreeze_local_instances,
  induction h_dim : findim α β using nat.strong_induction_on with n ih generalizing β,
  cases n,
  { have h_findim_top: findim α (⊤ : submodule α β) = 0 := eq.trans (@finite_dimensional.findim_top α β _ _ _ _) h_dim,
    have h_top_eq_bot : (⊤ : submodule α β) = ⊥ := bot_of_findim_zero _ h_findim_top,
    simp only [h_top_eq_bot, bot_le] },
  { have h_dim_pos : 0 < findim α β,
    { rw [h_dim],
      apply nat.zero_lt_succ },
    obtain ⟨x, μ₀, hx_ne_0, hμ₀⟩ : ∃ (x : β) (μ₀ : α), x ≠ 0 ∧ f x = μ₀ • x,
    { apply exists_eigenvector f
        (exists_mem_ne_zero_of_findim_pos h_dim_pos) },
    let V₁ := ((f - am μ₀) ^ n.succ).ker,
    let V₂ := ((f - am μ₀) ^ n.succ).range,
    have h_disjoint : disjoint V₂ V₁,
    { simp only [V₁, V₂, h_dim.symm],
      exact generalized_eigenvec_disjoint_range_ker f μ₀ },
    have h_dim_add : findim α V₂ + findim α V₁ = findim α β,
    { apply linear_map.findim_range_add_findim_ker },
    have h_dim_V₁_pos : 0 < findim α V₁,
    { apply pos_findim_eigenker_of_eigenvec ⟨hx_ne_0, hμ₀⟩ },
    have h_findim_V₂ : findim α V₂ < n.succ := by linarith,
    have h_f_V₂ : ∀ (x : β), x ∈ V₂ → f x ∈ V₂,
    { intros x hx,
      apply image_mem_eigenrange_of_mem_eigenrange hx, },
    have hV₂ : V₂ ≤ submodule.span α ({x : β | ∃ (k : ℕ) (μ : α), generalized_eigenvector f k μ x}),
    { have : V₂ ≤ submodule.span α ({x : β | ∃ (k : ℕ) (μ : α), generalized_eigenvector f k μ x} ∩ V₂),
      { rw ←subtype.image_preimage_val,
        rw ←submodule.subtype_eq_val V₂,
        rw submodule.span_image (submodule.subtype V₂),
        rw set.preimage_set_of_eq,
        rw submodule.subtype_eq_val,
        have h₀ : ∀ p, submodule.map (submodule.subtype V₂) ⊤
              ≤ submodule.map (submodule.subtype V₂) p
              ↔ ⊤ ≤ p
            := λ _, (linear_map.map_le_map_iff' (submodule.ker_subtype V₂)),
        have := submodule.range_subtype V₂,
        unfold linear_map.range at this,
        rw this at h₀,
        rw h₀,
        have := ih (findim α V₂) h_findim_V₂ (f.restrict V₂ V₂ h_f_V₂) rfl,
        simp only [generalized_eigenvector_restrict] at this,
        apply this },
      refine le_trans this _,
      apply submodule.span_mono,
      apply set.inter_subset_left },
    have hV₁ : V₁ ≤ submodule.span α ({x : β | ∃ (k : ℕ) (μ : α), generalized_eigenvector f k μ x}),
    { apply eigenker_le_span_gen_eigenvec },
    show ⊤ ≤ submodule.span α {x : β | ∃ (k : ℕ) (μ : α), generalized_eigenvector f k μ x},
    { rw ←finite_dimensional.eq_top_of_disjoint V₂ V₁ h_dim_add h_disjoint,
      apply sup_le hV₂ hV₁ } }
end


/-
Copyright (c) 2019 Bruno Bentzen. All rights reserved.
Released under the Apache License 2.0 (see "License");
Author: Bruno Bentzen
-/

import ...core.path

open interval path

-- non-dependent inversion and composition of lines

namespace path

def refl {A : Type} (a : A) : path A a a :=
path.abs (λ _, a) rfl rfl

def inv.filler {A : Type} {a b : A} (kan : has_hcom A) :
  path A a b → I → I → A :=
begin
  intro p, induction p with p _ _ p0 p1,
  unfold eq.mp at *; simp at *,
  apply (hcom (λ _, p i0) [[ p ; (λ _, p i0) ]] kan),
end

def inv {A : Type} {a b : A} (kan : has_hcom A) :
  path A a b → path A b a :=
begin
  intro p, fapply pathdp.abs,
  { exact inv.filler kan p i1 },
  repeat { reflexivity },
  induction p, transitivity, apply kan.eq0, assumption,
  induction p, transitivity, apply kan.eq1, assumption,
end

def comp.filler {A : Type} {a b c : A} (kan : has_hcom A) :
  path A a b → path A b c → I → I → A :=
begin
  intros p q,
  induction p with p _ _ p0 p1,
  induction q with q _ _ q0 q1,
  induction q0,
  exact (kan.hcom (horn1.mk p (λ _, p i0) q rfl p1)),
end

def comp {A : Type} {a b c : A} (kan : has_hcom A) :
  path A a b → path A b c → path A a c :=
begin
  intro p, induction p with p _ _ p0 p1,
  unfold eq.mp at *; simp at *,
  rw p0.symm, rw p1.symm,
  intro q, induction q with q _ _ q0 q1,
  unfold eq.mp at *; simp at *,
  rw q1.symm,
  fapply pathdp.abs,
  { apply (kan.hcom (horn1.mk p (λ _, p i0) q rfl q0.symm)) i1 },
  repeat { reflexivity },
  { transitivity, apply kan.eq0, unfold eq.mp; simp },
  { transitivity, apply kan.eq1, unfold eq.mp; simp },
end

end path

namespace refl

lemma eq {A : Type} {a : A} {p : I → A} (h : p = λ _, a ) {h0 : p i0 = a } {h1 : p i1 = a} :
  path.refl a = abs p h0 h1 :=
by cases h; refl

end refl


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.big_operators.basic
import algebra.big_operators.pi
import category_theory.limits.shapes.biproducts
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import data.matrix.dmatrix
import data.matrix.basic
import category_theory.Fintype
import category_theory.preadditive.single_obj
import algebra.opposites

/-!
# Matrices over a category.

When `C` is a preadditive category, `Mat_ C` is the preadditive category
whose objects are finite tuples of objects in `C`, and
whose morphisms are matrices of morphisms from `C`.

There is a functor `Mat_.embedding : C ⥤ Mat_ C` sending morphisms to one-by-one matrices.

`Mat_ C` has finite biproducts.

## The additive envelope

We show that this construction is the "additive envelope" of `C`,
in the sense that any additive functor `F : C ⥤ D` to a category `D` with biproducts
lifts to a functor `Mat_.lift F : Mat_ C ⥤ D`,
Moreover, this functor is unique (up to natural isomorphisms) amongst functors `L : Mat_ C ⥤ D`
such that `embedding C ⋙ L ≅ F`.
(As we don't have 2-category theory, we can't explicitly state that `Mat_ C` is
the initial object in the 2-category of categories under `C` which have biproducts.)

As a consequence, when `C` already has finite biproducts we have `Mat_ C ≌ C`.

## Future work

We should provide a more convenient `Mat R`, when `R` is a ring,
as a category with objects `n : FinType`,
and whose morphisms are matrices with components in `R`.

Ideally this would conveniently interact with both `Mat_` and `matrix`.

-/

open category_theory category_theory.preadditive
open_locale big_operators
noncomputable theory

namespace category_theory

universes w v₁ v₂ u₁ u₂
variables (C : Type u₁) [category.{v₁} C] [preadditive C]

/--
An object in `Mat_ C` is a finite tuple of objects in `C`.
-/
structure Mat_ : Type (max (v₁+1) u₁) :=
(ι : Type v₁)
[F : fintype ι]
[D : decidable_eq ι]
(X : ι → C)

attribute [instance] Mat_.F Mat_.D

namespace Mat_

variables {C}

/-- A morphism in `Mat_ C` is a dependently typed matrix of morphisms. -/
@[nolint has_inhabited_instance]
def hom (M N : Mat_ C) : Type v₁ := dmatrix M.ι N.ι (λ i j, M.X i ⟶ N.X j)

namespace hom

/-- The identity matrix consists of identity morphisms on the diagonal, and zeros elsewhere. -/
def id (M : Mat_ C) : hom M M := λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0

/-- Composition of matrices using matrix multiplication. -/
def comp {M N K : Mat_ C} (f : hom M N) (g : hom N K) : hom M K :=
λ i k, ∑ j : N.ι, f i j ≫ g j k

end hom

section
local attribute [simp] hom.id hom.comp

instance : category.{v₁} (Mat_ C) :=
{ hom := hom,
  id := hom.id,
  comp := λ M N K f g, f.comp g,
  id_comp' := λ M N f, by simp [dite_comp],
  comp_id' := λ M N f, by simp [comp_dite],
  assoc' := λ M N K L f g h, begin
    ext i k,
    simp_rw [hom.comp, sum_comp, comp_sum, category.assoc],
    rw finset.sum_comm,
  end, }.

lemma id_def (M : Mat_ C) :
  (𝟙 M : hom M M) = λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

lemma id_apply (M : Mat_ C) (i j : M.ι) :
  (𝟙 M : hom M M) i j = if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat_ C) (i : M.ι) :
  (𝟙 M : hom M M) i i = 𝟙 _ :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat_ C) (i j : M.ι) (h : i ≠ j) :
  (𝟙 M : hom M M) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N.ι, f i j ≫ g j k := rfl

@[simp] lemma comp_apply {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N.ι, f i j ≫ g j k := rfl

instance (M N : Mat_ C) : inhabited (M ⟶ N) := ⟨λ i j, (0 : M.X i ⟶ N.X j)⟩

end

instance : preadditive (Mat_ C) :=
{ hom_group := λ M N, by { change add_comm_group (dmatrix M.ι N.ι _), apply_instance, },
  add_comp' := λ M N K f f' g, by { ext, simp [finset.sum_add_distrib], },
  comp_add' := λ M N K f g g', by { ext, simp [finset.sum_add_distrib], }, }

@[simp] lemma add_apply {M N : Mat_ C} (f g : M ⟶ N) (i j) : (f + g) i j = f i j + g i j := rfl

open category_theory.limits

/--
We now prove that `Mat_ C` has finite biproducts.

Be warned, however, that `Mat_ C` is not necessarily Krull-Schmidt,
and so the internal indexing of a biproduct may have nothing to do with the external indexing,
even though the construction we give uses a sigma type.
See however `iso_biproduct_embedding`.
-/
instance has_finite_biproducts : has_finite_biproducts (Mat_ C) :=
{ has_biproducts_of_shape := λ J 𝒟 ℱ, by exactI
  { has_biproduct := λ f,
    has_biproduct_of_total
    { X := ⟨Σ j : J, (f j).ι, λ p, (f p.1).X p.2⟩,
      π := λ j x y,
      begin
        dsimp at x ⊢,
        refine if h : x.1 = j then _ else 0,
        refine if h' : (@eq.rec J x.1 (λ j, (f j).ι) x.2 _ h) = y then _ else 0,
        apply eq_to_hom,
        substs h h', -- Notice we were careful not to use `subst` until we had a goal in `Prop`.
      end,
      ι := λ j x y,
      begin
        dsimp at y ⊢,
        refine if h : y.1 = j then _ else 0,
        refine if h' : (@eq.rec J y.1 (λ j, (f j).ι) y.2 _ h) = x then _ else 0,
        apply eq_to_hom,
        substs h h',
      end,
      ι_π := λ j j',
      begin
        ext x y,
        dsimp,
        simp_rw [dite_comp, comp_dite],
        simp only [if_t_t, dite_eq_ite, dif_ctx_congr, limits.comp_zero, limits.zero_comp,
          eq_to_hom_trans, finset.sum_congr],
        erw finset.sum_sigma,
        dsimp,
        simp only [if_congr, if_true, dif_ctx_congr, finset.sum_dite_irrel, finset.mem_univ,
          finset.sum_const_zero, finset.sum_congr, finset.sum_dite_eq'],
        split_ifs with h h',
        { substs h h',
          simp only [category_theory.eq_to_hom_refl, category_theory.Mat_.id_apply_self], },
        { subst h,
          simp only [id_apply_of_ne _ _ _ h', category_theory.eq_to_hom_refl], },
        { refl, },
      end, }
    begin
      dsimp,
      funext i₁,
      dsimp at i₁ ⊢,
      rcases i₁ with ⟨j₁, i₁⟩,
      -- I'm not sure why we can't just `simp` by `finset.sum_apply`: something doesn't quite match
      convert finset.sum_apply _ _ _ using 1,
      { refl, },
      { apply heq_of_eq,
        symmetry,
        funext i₂,
        rcases i₂ with ⟨j₂, i₂⟩,
        simp only [comp_apply, dite_comp, comp_dite,
          if_t_t, dite_eq_ite, if_congr, if_true, dif_ctx_congr,
          finset.sum_dite_irrel, finset.sum_dite_eq, finset.mem_univ, finset.sum_const_zero,
          finset.sum_congr, finset.sum_dite_eq, finset.sum_apply,
          limits.comp_zero, limits.zero_comp, eq_to_hom_trans, Mat_.id_apply],
        by_cases h : j₁ = j₂,
        { subst h, simp, },
        { simp [h], }, },
    end }}.

end Mat_

namespace functor
variables {C} {D : Type*} [category.{v₁} D] [preadditive D]

local attribute [simp] Mat_.id_apply

/--
A functor induces a functor of matrix categories.
-/
@[simps]
def map_Mat_ (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ Mat_ D :=
{ obj := λ M, ⟨M.ι, λ i, F.obj (M.X i)⟩,
  map := λ M N f i j, F.map (f i j),
  map_comp' := λ M N K f g, by { ext i k, simp,}, }

/--
The identity functor induces the identity functor on matrix categories.
-/
@[simps]
def map_Mat_id : (𝟭 C).map_Mat_ ≅ 𝟭 (Mat_ C) :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

/--
Composite functors induce composite functors on matrix categories.
-/
@[simps]
def map_Mat_comp {E : Type*} [category.{v₁} E] [preadditive E]
  (F : C ⥤ D) [functor.additive F] (G : D ⥤ E) [functor.additive G] :
  (F ⋙ G).map_Mat_ ≅ F.map_Mat_ ⋙ G.map_Mat_ :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

end functor

namespace Mat_

variables (C)

/-- The embedding of `C` into `Mat_ C` as one-by-one matrices.
(We index the summands by `punit`.) -/
@[simps]
def embedding : C ⥤ Mat_ C :=
{ obj := λ X, ⟨punit, λ _, X⟩,
  map := λ X Y f, λ _ _, f,
  map_id' := λ X, by { ext ⟨⟩ ⟨⟩, simp, },
  map_comp' := λ X Y Z f g, by { ext ⟨⟩ ⟨⟩, simp, }, }

namespace embedding

instance : faithful (embedding C) :=
{ map_injective' := λ X Y f g h, congr_fun (congr_fun h punit.star) punit.star, }

instance : full (embedding C) :=
{ preimage := λ X Y f, f punit.star punit.star, }

instance : functor.additive (embedding C) := {}

end embedding

instance [inhabited C] : inhabited (Mat_ C) := ⟨(embedding C).obj default⟩

open category_theory.limits

variables {C}

/--
Every object in `Mat_ C` is isomorphic to the biproduct of its summands.
-/
@[simps]
def iso_biproduct_embedding (M : Mat_ C) : M ≅ ⨁ (λ i, (embedding C).obj (M.X i)) :=
{ hom := biproduct.lift (λ i j k, if h : j = i then eq_to_hom (congr_arg M.X h) else 0),
  inv := biproduct.desc (λ i j k, if h : i = k then eq_to_hom (congr_arg M.X h) else 0),
  hom_inv_id' :=
  begin
    simp only [biproduct.lift_desc],
    funext i,
    dsimp,
    convert finset.sum_apply _ _ _,
    { dsimp, refl, },
    { apply heq_of_eq,
      symmetry,
      funext j,
      simp only [finset.sum_apply],
      dsimp,
      simp [dite_comp, comp_dite, Mat_.id_apply], }
  end,
  inv_hom_id' :=
  begin
    apply biproduct.hom_ext,
    intro i,
    apply biproduct.hom_ext',
    intro j,
    simp only [category.id_comp, category.assoc,
      biproduct.lift_π, biproduct.ι_desc_assoc, biproduct.ι_π],
    ext ⟨⟩ ⟨⟩,
    simp [dite_comp, comp_dite],
    split_ifs,
    { subst h, simp, },
    { simp [h], },
  end, }.

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

/-- Every `M` is a direct sum of objects from `C`, and `F` preserves biproducts. -/
@[simps]
def additive_obj_iso_biproduct (F : Mat_ C ⥤ D) [functor.additive F] (M : Mat_ C) :
  F.obj M ≅ ⨁ (λ i, F.obj ((embedding C).obj (M.X i))) :=
(F.map_iso (iso_biproduct_embedding M)) ≪≫ (F.map_biproduct _)

variables [has_finite_biproducts D]

@[reassoc] lemma additive_obj_iso_biproduct_naturality (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  F.map f ≫ (additive_obj_iso_biproduct F N).hom =
    (additive_obj_iso_biproduct F M).hom ≫
      biproduct.matrix (λ i j, F.map ((embedding C).map (f i j))) :=
begin
  -- This is disappointingly tedious.
  ext,
  simp only [additive_obj_iso_biproduct_hom, category.assoc, biproduct.lift_π, functor.map_bicone_π,
    biproduct.bicone_π, biproduct.lift_matrix],
  dsimp [embedding],
  simp only [←F.map_comp, biproduct.lift_π, biproduct.matrix_π, category.assoc],
  simp only [←F.map_comp, ←F.map_sum, biproduct.lift_desc, biproduct.lift_π_assoc, comp_sum],
  simp only [comp_def, comp_dite, comp_zero, finset.sum_dite_eq', finset.mem_univ, if_true],
  dsimp,
  simp only [finset.sum_singleton, dite_comp, zero_comp],
  congr,
  symmetry,
  convert finset.sum_fn _ _, -- It's hard to use this as a simp lemma!
  simp only [finset.sum_fn, finset.sum_dite_eq],
  ext,
  simp,
end

@[reassoc] lemma additive_obj_iso_biproduct_naturality' (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  (additive_obj_iso_biproduct F M).inv ≫ F.map f =
    biproduct.matrix (λ i j, F.map ((embedding C).map (f i j)) : _) ≫
      (additive_obj_iso_biproduct F N).inv :=
by rw [iso.inv_comp_eq, ←category.assoc, iso.eq_comp_inv, additive_obj_iso_biproduct_naturality]

/-- Any additive functor `C ⥤ D` to a category `D` with finite biproducts extends to
a functor `Mat_ C ⥤ D`. -/
@[simps]
def lift (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ D :=
{ obj := λ X, ⨁ (λ i, F.obj (X.X i)),
  map := λ X Y f, biproduct.matrix (λ i j, F.map (f i j)),
  map_id' := λ X, begin
    ext i j,
    by_cases h : i = j,
    { subst h, simp, },
    { simp [h, Mat_.id_apply], },
  end,
  map_comp' := λ X Y Z f g, by { ext i j, simp, }, }.

instance lift_additive (F : C ⥤ D) [functor.additive F] : functor.additive (lift F) := {}

/-- An additive functor `C ⥤ D` factors through its lift to `Mat_ C ⥤ D`. -/
@[simps]
def embedding_lift_iso (F : C ⥤ D) [functor.additive F] : embedding C ⋙ lift F ≅ F :=
nat_iso.of_components (λ X,
  { hom := biproduct.desc (λ P, 𝟙 (F.obj X)),
    inv := biproduct.lift (λ P, 𝟙 (F.obj X)), })
(λ X Y f, begin
  dsimp,
  ext,
  simp only [category.id_comp, biproduct.ι_desc_assoc],
  erw biproduct.ι_matrix_assoc, -- Not sure why this doesn't fire via `simp`.
  simp,
end).

/--
`Mat_.lift F` is the unique additive functor `L : Mat_ C ⥤ D` such that `F ≅ embedding C ⋙ L`.
-/
def lift_unique (F : C ⥤ D) [functor.additive F] (L : Mat_ C ⥤ D) [functor.additive L]
  (α : embedding C ⋙ L ≅ F) :
  L ≅ lift F :=
nat_iso.of_components
  (λ M, (additive_obj_iso_biproduct L M) ≪≫
    (biproduct.map_iso (λ i, α.app (M.X i))) ≪≫
    (biproduct.map_iso (λ i, (embedding_lift_iso F).symm.app (M.X i))) ≪≫
    (additive_obj_iso_biproduct (lift F) M).symm)
(λ M N f, begin
  dsimp only [iso.trans_hom, iso.symm_hom, biproduct.map_iso_hom],
  simp only [additive_obj_iso_biproduct_naturality_assoc],
  simp only [biproduct.matrix_map_assoc, category.assoc],
  simp only [additive_obj_iso_biproduct_naturality'],
  simp only [biproduct.map_matrix_assoc, category.assoc],
  congr,
  ext j k ⟨⟩,
  dsimp, simp,
  convert α.hom.naturality (f j k),
  erw [biproduct.matrix_π],
  simp,
end).

-- TODO is there some uniqueness statement for the natural isomorphism in `lift_unique`?

/-- Two additive functors `Mat_ C ⥤ D` are naturally isomorphic if
their precompositions with `embedding C` are naturally isomorphic as functors `C ⥤ D`. -/
@[ext]
def ext {F G : Mat_ C ⥤ D} [functor.additive F] [functor.additive G]
  (α : embedding C ⋙ F ≅ embedding C ⋙ G) : F ≅ G :=
(lift_unique (embedding C ⋙ G) _ α) ≪≫ (lift_unique _ _ (iso.refl _)).symm

/--
Natural isomorphism needed in the construction of `equivalence_self_of_has_finite_biproducts`.
-/
def equivalence_self_of_has_finite_biproducts_aux [has_finite_biproducts C] :
  embedding C ⋙ 𝟭 (Mat_ C) ≅ embedding C ⋙ lift (𝟭 C) ⋙ embedding C :=
functor.right_unitor _ ≪≫
  (functor.left_unitor _).symm ≪≫
  (iso_whisker_right (embedding_lift_iso _).symm _) ≪≫
  functor.associator _ _ _

/--
A preadditive category that already has finite biproducts is equivalent to its additive envelope.

Note that we only prove this for a large category;
otherwise there are universe issues that I haven't attempted to sort out.
-/
def equivalence_self_of_has_finite_biproducts
  (C : Type (u₁+1)) [large_category C] [preadditive C] [has_finite_biproducts C] :
  Mat_ C ≌ C :=
equivalence.mk -- I suspect this is already an adjoint equivalence, but it seems painful to verify.
  (lift (𝟭 C))
  (embedding C)
  (ext equivalence_self_of_has_finite_biproducts_aux)
  (embedding_lift_iso (𝟭 C))

@[simp] lemma equivalence_self_of_has_finite_biproducts_functor
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).functor = lift (𝟭 C) :=
rfl

@[simp] lemma equivalence_self_of_has_finite_biproducts_inverse
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).inverse = embedding C :=
rfl

end Mat_

universe u

/-- A type synonym for `Fintype`, which we will equip with a category structure
where the morphisms are matrices with components in `R`. -/
@[nolint unused_arguments, derive inhabited]
def Mat (R : Type u) := Fintype.{u}

instance (R : Type u) : has_coe_to_sort (Mat R) (Type u) := bundled.has_coe_to_sort

open_locale classical matrix

instance (R : Type u) [semiring R] : category (Mat R) :=
{ hom := λ X Y, matrix X Y R,
  id := λ X, 1,
  comp := λ X Y Z f g, f ⬝ g,
  assoc' := by { intros, simp [matrix.mul_assoc], }, }

namespace Mat

section
variables (R : Type u) [semiring R]

lemma id_def (M : Mat R) :
  𝟙 M = λ i j, if h : i = j then 1 else 0 :=
rfl

lemma id_apply (M : Mat R) (i j : M) :
  (𝟙 M : matrix M M R) i j = if h : i = j then 1 else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat R) (i : M) :
  (𝟙 M : matrix M M R) i i = 1 :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat R) (i j : M) (h : i ≠ j) :
  (𝟙 M : matrix M M R) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N, f i j * g j k := rfl

@[simp] lemma comp_apply {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N, f i j * g j k := rfl

instance (M N : Mat R) : inhabited (M ⟶ N) := ⟨λ (i : M) (j : N), (0 : R)⟩

end

variables (R : Type u) [ring R]

open opposite

/-- Auxiliary definition for `category_theory.Mat.equivalence_single_obj`. -/
@[simps]
def equivalence_single_obj_inverse : Mat_ (single_obj Rᵐᵒᵖ) ⥤ Mat R :=
{ obj := λ X, Fintype.of X.ι,
  map := λ X Y f i j, mul_opposite.unop (f i j),
  map_id' := λ X, by { ext i j, simp [id_def, Mat_.id_def], split_ifs; refl, }, }

instance : faithful (equivalence_single_obj_inverse R) :=
{ map_injective' := λ X Y f g w, begin
    ext i j,
    apply_fun mul_opposite.unop using mul_opposite.unop_injective,
    exact (congr_fun (congr_fun w i) j),
  end }

instance : full (equivalence_single_obj_inverse R) :=
{ preimage := λ X Y f i j, mul_opposite.op (f i j), }

instance : ess_surj (equivalence_single_obj_inverse R) :=
{ mem_ess_image := λ X,
  ⟨{ ι := X, X := λ _, punit.star }, ⟨eq_to_iso (by { dsimp, cases X, congr, })⟩⟩, }

/-- The categorical equivalence between the category of matrices over a ring,
and the category of matrices over that ring considered as a single-object category. -/
def equivalence_single_obj : Mat R ≌ Mat_ (single_obj Rᵐᵒᵖ) :=
begin
  haveI := equivalence.of_fully_faithfully_ess_surj (equivalence_single_obj_inverse R),
  exact (equivalence_single_obj_inverse R).as_equivalence.symm,
end

instance : preadditive (Mat R) :=
{ add_comp' := by { intros, ext, simp [add_mul, finset.sum_add_distrib], },
  comp_add' := by { intros, ext, simp [mul_add, finset.sum_add_distrib], }, }

-- TODO show `Mat R` has biproducts, and that `biprod.map` "is" forming a block diagonal matrix.

end Mat

end category_theory


import algebra.homology.homological_complex

open category_theory category_theory.limits

namespace homological_complex

universes w' w v v' u u'

variables {V : Type u} [category.{v} V] {J : Type w} [category.{w'} J]
variables {ι : Type u'} {c : complex_shape ι}

-- move this
section
variables {C : Type u} [category.{v} C] {Z : C → Prop}
@[simps]
def lift_iso {X Y : { X : C // Z X }} (h : (X : C) ≅ Y) : X ≅ Y :=
{ hom := h.hom, inv := h.inv, hom_inv_id' := h.hom_inv_id, inv_hom_id' := h.inv_hom_id }
end

section walking_complex

@[nolint unused_arguments]
def walking_complex (c : complex_shape ι) := ι

inductive walking_complex_hom : walking_complex c → walking_complex c → Type u'
| id : Π i, walking_complex_hom i i
| d : Π {i j}, c.rel i j → walking_complex_hom i j
| zero : Π i j, walking_complex_hom i j

section

open walking_complex_hom

def walking_complex_hom_comp (i j k : walking_complex c) :
  walking_complex_hom i j → walking_complex_hom j k → walking_complex_hom i k :=
begin
  intros f g,
  cases f with _ _ _ r,
  { exact g },
  { cases g, exacts [walking_complex_hom.d r, walking_complex_hom.zero _ _, walking_complex_hom.zero _ _] },
  { exact walking_complex_hom.zero _ _ },
end

instance : category_struct (walking_complex c) :=
{ hom := walking_complex_hom,
  id := walking_complex_hom.id,
  comp :=
  begin
    intros i j k f g,
    cases f with _ _ _ r,
    { exact g },
    { cases g, exacts [walking_complex_hom.d r, walking_complex_hom.zero _ _, walking_complex_hom.zero _ _] },
    { exact walking_complex_hom.zero _ _ },
  end }
end

local attribute [tidy] tactic.case_bash

instance : category (walking_complex c) := {}
.

instance walking_complex_hom_has_zero (i j : walking_complex c) : has_zero (i ⟶ j) :=
⟨walking_complex_hom.zero i j⟩

instance : has_zero_morphisms (walking_complex c) := {}
.

@[simp] lemma walking_complex_hom_id (i : walking_complex c) : walking_complex_hom.id i = 𝟙 i :=
rfl
@[simp] lemma walking_complex_hom_zero (i : walking_complex c) : walking_complex_hom.zero i = 0 :=
rfl

def walking_complex_d {i j : walking_complex c} (r : c.rel i j) : i ⟶ j :=
  walking_complex_hom.d r

@[simp] lemma walking_complex_d_eq {i j : walking_complex c} (r : c.rel i j) :
  walking_complex_hom.d r = walking_complex_d r := rfl

@[simp] lemma walking_complex_hom_d_comp_d {i j k : walking_complex c}
  (r : c.rel i j) (r' : c.rel j k) : walking_complex_d r ≫ walking_complex_d r' = 0 := rfl

variable [has_zero_morphisms V]

def complex_to_functor_map
  (h : homological_complex V c) {i j : walking_complex c} (f : i ⟶ j) : h.X i ⟶ h.X j :=
begin
  cases f, exacts [𝟙 _, h.d _ _, 0]
end

@[simp]
lemma complex_to_functor_map_id
  (h : homological_complex V c) (i : walking_complex c) : complex_to_functor_map h (𝟙 i) = 𝟙 _ :=
rfl

@[simp]
lemma complex_to_functor_map_zero
  (h : homological_complex V c) (i j : walking_complex c) :
    complex_to_functor_map h (0 : i ⟶ j) = 0 :=
rfl

@[simp]
lemma complex_to_functor_map_d
  (h : homological_complex V c) {i j : walking_complex c} (r : c.rel i j) :
    complex_to_functor_map h (walking_complex_d r) = h.d _ _ := rfl

@[simps]
def complex_to_functor (h : homological_complex V c) :
  walking_complex c ⥤ V :=
{ obj := h.X, map := λ i j f, complex_to_functor_map h f }
.

variable [decidable_rel c.rel]

@[simps]
def functor_to_complex (F : walking_complex c ⥤ V)
  (hF : ∀ i j, F.map (0 : i ⟶ j) = 0) :
  homological_complex V c :=
{ X := F.obj,
  d := λ i j, if r : c.rel i j then F.map (walking_complex_d r) else 0,
  d_comp_d' := by { introv r r',
    rw [dif_pos r, dif_pos r', ← F.map_comp, walking_complex_hom_d_comp_d, hF] } }
.
variables (c V)

@[simps]
def complex_to_functor_functor :
  homological_complex V c ⥤ { F : walking_complex c ⥤ V // ∀ i j, F.map (0 : i ⟶ j) = 0 } :=
{ obj := λ X, ⟨complex_to_functor X, λ _ _, rfl⟩, map := λ X Y f, { app := f.f } }

@[simps]
def functor_to_complex_functor :
  { F : walking_complex c ⥤ V // ∀ i j, F.map (0 : i ⟶ j) = 0 } ⥤ homological_complex V c :=
{ obj := λ F, functor_to_complex F.1 F.2,
  map := λ F G f, { f := f.app, comm' := by { intros i j r, simp [dif_pos r] } } }
.

@[simps]
def complex_equiv_functor_unit :
  𝟭 _ ≅ complex_to_functor_functor V c ⋙ functor_to_complex_functor V c :=
nat_iso.of_components
  (λ X, hom.iso_of_components (λ i, iso.refl _) (by { introv r, dsimp, simp [if_pos r] }))
  (by { intros, ext, dsimp, simp })

@[simps]
def complex_equiv_functor_counit :
  functor_to_complex_functor V c ⋙ complex_to_functor_functor V c ≅ 𝟭 _ :=
nat_iso.of_components
  (λ F, lift_iso $ nat_iso.of_components (λ i, iso.refl _)
    (by { introv, cases F with F hF, cases f; dsimp; simp [*, hF] }))
  (by { introv, ext, dsimp, erw [nat_trans.comp_app, nat_trans.comp_app], dsimp, simp })

@[simps]
def complex_equiv_functor :
  homological_complex V c ≌ { F : walking_complex c ⥤ V // ∀ i j, F.map (0 : i ⟶ j) = 0 } :=
{ functor := complex_to_functor_functor V c,
  inverse := functor_to_complex_functor V c,
  unit_iso := complex_equiv_functor_unit V c,
  counit_iso := complex_equiv_functor_counit V c,
  functor_unit_iso_comp' :=
    by { intro x, ext, erw [nat_trans.comp_app, nat_trans.id_app], dsimp, simp } }
.

instance : is_equivalence (complex_to_functor_functor V c) :=
is_equivalence.of_equivalence (complex_equiv_functor V c)
instance : is_equivalence (functor_to_complex_functor V c) :=
is_equivalence.of_equivalence_inverse (complex_equiv_functor V c)

@[simps, derive [full, faithful]]
def complex_to_functor_category_functor : homological_complex V c ⥤ walking_complex c ⥤ V :=
complex_to_functor_functor V c ⋙ induced_functor _

end walking_complex

section walking_preadditive_complex

/-
TODO : If `V` is preadditive, then the cateogory of homological complexes is equivalent to the
category of additive functors from a preadditive category `walking_preadditive_complex` to `V`.
-/

end walking_preadditive_complex

end homological_complex


import homotopy_theory.formal.cylinder.homotopy
import .definitions
import .lemmas

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
open homotopy_theory.cylinder

namespace equiv_private
section
open category_theory.has_initial_object category_theory.preserves_initial_object
open category_theory.preserves_coproducts
open precofibration_category I_category

/-

Goal: If j : a → b is a cofibration, then homotopy rel j is an
equivalence relation. More generally, we will prove the
following. Suppose that G : Ia → x is a homotopy. In the diagram

  f₀  - f₁
  |
  f₀' - f₁'

suppose that f₀ ≃ f₀' rel j and that f₀ ≃ f₁ and f₀' ≃ f₁' via
homotopies that each restrict to G on a. Then f₁ ≃ f₁' rel j. By
taking G to be a constant homotopy, we conclude in particular that
homotopy rel j is an equivalence relation.

-/

parameters {C : Type u} [category.{v} C] [has_initial_object.{v} C]
  [has_coproducts.{v} C] [I_category.{v} C]

parameters {a b : C} (j : a ⟶ b) (hj : is_cof j)
parameters {x : C} {f₀ f₀' f₁ f₁' : b ⟶ x}
parameters {G : I.obj a ⟶ x}
parameters {H₀ : homotopy f₀ f₀'} (h₀ : H₀.is_rel j)

-- Furthermore, we generalize over the direction of the homotopies
-- between f₀ and f₁ and between f₀' and f₁'.
parameters (ε : endpoint)
parameters {H : homotopy_dir ε f₀ f₁} (h : H.H ∘ I &> j = G)
parameters {H' : homotopy_dir ε f₀' f₁'} (h' : H'.H ∘ I &> j = G)
-- Goal: construct a homotopy from f₁ to f₂ rel j.

/-
  a ⊔ a →   Ia
    ↓       ↓
  b ⊔ b → b_Ia_b
-/

def Po : pushout (∂I &> j) (ii @> a) := pushout_by_cof _ _ (cof_coprod hj hj)
def b_Ia_b := Po.ob

-- I preserves the above pushout.
def Ipo : Is_pushout (I &> (∂I &> j)) (I &> (ii @> a)) (I &> Po.map₀) (I &> Po.map₁) :=
I_preserves_pushout_by_cof (cof_coprod hj hj) Po.is_pushout
-- Moreover, I(a ⊔ a) = Ia ⊔ Ia and I(b ⊔ b) = Ib ⊔ Ib.
def Ia_Ia : Is_coproduct (I &> (i₀ : a ⟶ a ⊔ a)) (I &> (i₁ : a ⟶ a ⊔ a)) :=
I_of_coprod_is_coproduct
def Ib_Ib : Is_coproduct (I &> (i₀ : b ⟶ b ⊔ b)) (I &> (i₁ : b ⟶ b ⊔ b)) :=
I_of_coprod_is_coproduct
-- Thus, we can "glue" the homotopies H and H' to form a map I(b ⊔ b) → X.
def HH' : I.obj (b ⊔ b) ⟶ x :=
Ib_Ib.induced H.H H'.H
-- Because the homotopies agree on a, the restriction of this map to I(a ⊔ a)
-- extends to a map I(Ia) → X. Then we get an induced map on I(b ⊔ₐ Ia ⊔ₐ b).
def GIp : I.obj (I.obj a) ⟶ x := G ∘ I &> (p @> a)

include h h'
def HH'' : I.obj b_Ia_b ⟶ x :=
Ipo.induced HH' GIp $
  -- This is a bit awful
  begin
    apply Ia_Ia.uniqueness;
    rw [←assoc, ←assoc, ←I.map_comp, ←I.map_comp];
    change
      _ ∘ I &> (coprod_of_maps j j ∘ _) =
      _ ∘ I &> (coprod.induced (i 0 @> a) (i 1 @> a) ∘ _);
    simp [HH', GIp]; rw h <|> rw h';
    rw [←assoc, ←I.map_comp]; simp
  end
omit h h'

-- The map guaranteed to be a cofibration by the relative cylinder axiom.
-- Induced map in same pushout square as above.
def j' := Po.is_pushout.induced (ii @> b) (I &> j) (ii.naturality _)

include h₀
lemma HH''iε : H₀.H ∘ j' = HH'' ∘ i ε @> _ :=
have t : ∀ {z} (k : z ⟶ _), H₀.H ∘ j' ∘ k = H₀.H ∘ (j' ∘ k), by simp,
begin
  unfold HH'' HH',
  apply Po.is_pushout.uniqueness,
  -- This is truly awful
  { rw i_nat_assoc,
    apply coprod.uniqueness;
    { simp, erw i_nat_assoc, simp,
      rw t, unfold j' ii, simp, rw ←assoc, simp,
      erw H₀.Hi₀ <|> erw H₀.Hi₁,
      erw H.Hiε <|> erw H'.Hiε } },
  { rw [i_nat_assoc, t], unfold j' GIp, simp,
    erw [←i_nat_assoc, ←h, ←i_nat_assoc, H.Hiε],
    exact h₀ }
end
omit h₀

-- Now we can apply the homotopy extension property of j'
lemma Ex_E : ∃ (E : I.obj (I.obj b) ⟶ x),
  E ∘ i ε @> (I.obj b) = H₀.H ∧ E ∘ I &> j' = HH'' :=
hep_cof j' (relative_cylinder j hj) ε _ _ _ HH''iε

section E
parameters (E : I.obj (I.obj b) ⟶ x)
  (hE : E ∘ i ε @> I.obj b = H₀.H ∧ E ∘ I &> j' = HH'')
-- Now E ∘ i ε.v is supposed to be a homotopy from f₁ to f₁' rel j.

include hE
lemma Eiεvi_ :
  E ∘ i ε.v @> I.obj b ∘ i 0 @> b = f₁ ∧
  E ∘ i ε.v @> I.obj b ∘ i 1 @> b = f₁' :=
have
  i.{v} ε.v @> I.obj b ∘ i 0 @> b = I &> j' ∘ I &> Po.map₀ ∘ i ε.v @> _ ∘ i₀ ∧
  i.{v} ε.v @> I.obj b ∘ i 1 @> b = I &> j' ∘ I &> Po.map₀ ∘ i ε.v @> _ ∘ i₁, begin
  split;
  { rw ←I.map_comp, unfold j', simp, erw i_nat_assoc,
    rw ←I.map_comp, dsimp [ii], simp,
    apply (i _).naturality }
end,
begin
  split;
  { rw ←assoc, rw this.1 <|> rw this.2,
    simp [hE.2, HH'', HH'],
    erw i_nat_assoc, dsimp, simp,
    -- dsimp: coprod vs (has_coproducts.coproduct _ _).ob?
    exact H.Hiεv <|> exact H'.Hiεv }
end

def Eiε : homotopy f₁ f₁' :=
{ H := E ∘ i ε.v @> I.obj b, Hi₀ := Eiεvi_.1, Hi₁ := Eiεvi_.2 }

lemma Eiε_is_rel : Eiε.is_rel j :=
have i ε.v @> I.obj b ∘ I &> j = I &> j' ∘ I &> Po.map₁ ∘ i ε.v @> I.obj a, begin
  rw ←I.map_comp, unfold j', simp,
  rw ←(i ε.v).naturality, refl
end,
begin
  dsimp [homotopy.is_rel, Eiε] { iota := tt },
  rw [←assoc, this], simp [hE.2, HH'', GIp],
  rw [←h, ←i_nat_assoc, ←i_nat_assoc, H.Hiεv]
end

end E

lemma f₁_f₂ : f₁ ≃ f₁' rel j :=
let ⟨E, hE⟩ := Ex_E in ⟨Eiε E hE, Eiε_is_rel E hE⟩

end
end equiv_private

end homotopy_theory.cofibrations

-- TODO: Is this a sensible place to put these?
namespace homotopy_theory.cylinder
open homotopy_theory.cofibrations

variables {C : Type u} [category.{v} C]
  [has_initial_object.{v} C] [has_coproducts.{v} C] [I_category.{v} C]
variables {a b : C} {j : a ⟶ b} (hj : is_cof j)

lemma homotopic_rel.symm_trans {x : C} {f₀ f₁ f₂ : b ⟶ x} :
  f₀ ≃ f₁ rel j → f₀ ≃ f₂ rel j → f₁ ≃ f₂ rel j :=
assume ⟨H₁, h₁⟩ ⟨H₂, h₂⟩, equiv_private.f₁_f₂ j hj homotopy.refl_is_rel 0 h₁ h₂

lemma homotopic_rel.symm {x : C} {f₀ f₁ : b ⟶ x} (h : f₀ ≃ f₁ rel j) : f₁ ≃ f₀ rel j :=
homotopic_rel.symm_trans hj h (homotopic_rel.refl _)

lemma homotopic_rel.trans {x : C} {f₀ f₁ f₂ : b ⟶ x}
  (h₁ : f₀ ≃ f₁ rel j) (h₂ : f₁ ≃ f₂ rel j) : f₀ ≃ f₂ rel j :=
homotopic_rel.symm_trans hj (h₁.symm hj) h₂

lemma homotopic_rel_is_equivalence {x : C} :
  equivalence (homotopic_rel j : (b ⟶ x) → (b ⟶ x) → Prop) :=
⟨homotopic_rel.refl,
 λ f₀ f₁, homotopic_rel.symm hj,
 λ f₀ f₁ f₂, homotopic_rel.trans hj⟩

@[symm] lemma homotopic.symm {x : C} {f₀ f₁ : b ⟶ x} (h : f₀ ≃ f₁) : f₁ ≃ f₀ :=
begin
  rw ←(homotopic_rel_initial Ii_initial (! b)) at ⊢ h,
  exact homotopic_rel.symm (all_objects_cofibrant.cofibrant.{v} b) h,
end

@[trans] lemma homotopic.trans {x : C} {f₀ f₁ f₂ : b ⟶ x} (h₁ : f₀ ≃ f₁) (h₂ : f₁ ≃ f₂) : f₀ ≃ f₂ :=
begin
  rw ←(homotopic_rel_initial Ii_initial (! b)) at ⊢ h₁ h₂,
  exact homotopic_rel.trans (all_objects_cofibrant.cofibrant.{v} b) h₁ h₂,
end

lemma homotopic_is_equivalence {x : C} :
  equivalence (homotopic : (b ⟶ x) → (b ⟶ x) → Prop) :=
⟨homotopic.refl, λ f₀ f₁, homotopic.symm, λ f₀ f₁ f₂, homotopic.trans⟩

end homotopy_theory.cylinder


/-
Copyright 2021 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import measure_theory.measurable_space

import measure_theory.measure_space
import measure_theory.outer_measure
import measure_theory.lebesgue_measure
import measure_theory.integration

import measure_theory.borel_space
import data.set.countable
import formal_ml.nnreal
import formal_ml.sum
import formal_ml.lattice
import formal_ml.measurable_space
import formal_ml.classical
import data.equiv.list
import formal_ml.prod_measure
import formal_ml.finite_pi_measure
import formal_ml.probability_space

/-!
  This file focuses on more esoteric proofs that random variables are identical
  and independent. These are based upon the monotone class theorem.

  Semi-algebras are the basic object. A sigma algebra or algebra is a semi-algebra.
  For example, the set of (closed, open, half-open) intervals on the real line form a
  semi-algebra. The simplest sets in a product of a measurable space form a semi-algebra.

  If you close a semi-algebra under finite disjoint union, it becomes an algebra.

  An algebra is defined as containing the universal set and being closed under set
  difference. However, it is also closed under finite union, intersection, complement,
  and it contains the empty set.

  The monotone class of a set is the closure under monotone intersection and monotone
  union. The monotone class of an algebra is a sigma algebra (the monotone class theorem).

  This file contains the definition of a monotone class, a semi-algebra, and an algebra.
  (set.monotone_class, set.is_semialgebra, and set.is_algebra). It also contains
  the definition of closure under finite disjoint union.

  This is most useful for proving independent and identical random variables, when
  considered as an aggregate random variable, are identical.

  The core is the monotone class theorem, measurable_space.generate_from_monotone_class.
-/

/-- A monotone class: an extension of a set of sets to be closed under
   monotone intersection and union.
   When a monotone class extends an algebra (not a sigma algebra, just a regular algebra),
   it is equivalent to the
   measurable space generated from the algebra.

   First, we introduce the properties of algebras. Then, we show that the
   result of a monotone class of an algebra is an algebra. Finally, we
   show the monotone class of an algebra is a sigma algebra (i.e., a
   measurable space).
   See measurable_space.generate_from_monotone_class
 -/
inductive set.monotone_class {α:Type*} (s : set (set α)) : set α → Prop
| basic : ∀ u, u∈ s → set.monotone_class u
| inter : ∀ f : ℕ → set α, (∀ n, set.monotone_class (f n)) →
                           (∀ (i:ℕ), f i.succ ⊆ f i) →
                           set.monotone_class (set.Inter f)
| union : ∀ f : ℕ → set α, (∀ n, set.monotone_class (f n)) →
                           monotone f →
                            set.monotone_class (set.Union f)

--namespace measure_theory

structure set.is_algebra {α:Type*} (s:set (set α)) :=
  (univ : set.univ ∈ s)
  (diff : ∀ a b, a ∈ s →  b ∈ s → (a \ b) ∈ s)

lemma set.is_algebra.compl {α:Type*} {s:set (set α)} (A:s.is_algebra):
  (∀ a, a∈ s → aᶜ ∈ s) := begin
  intros a h_a,
  have h3:aᶜ = set.univ \ a,
  { ext ω, split; intros h3_1; simp at h3_1; simp [h3_1] },
  rw h3,
  apply A.diff,
  apply A.univ,
  apply h_a
end

lemma set.is_algebra.empty {α:Type*} {s:set (set α)} (A:s.is_algebra):
  (∅ ∈ s) := begin
  rw ← set.compl_univ,
  apply A.compl,
  apply A.univ,
end

lemma set.is_algebra.inter {α:Type*} {s:set (set α)} (A:s.is_algebra):
  (∀ a b, a∈ s → b∈ s→ a∩ b ∈ s) := begin
  intros a b h_a h_b,
  have h3:a ∩ b = a \ bᶜ,
  { ext ω, split; intros h3_1; simp at h3_1; simp [h3_1] },
  rw h3,
  apply A.diff,
  apply h_a,
  apply A.compl,
  apply h_b,
end

lemma set.is_algebra.union {α:Type*} {s : set (set α)} (A:s.is_algebra):
  (∀ a b, a∈ s → b ∈ s → a ∪ b ∈ s) := begin
  intros a b h_a h_b,
  have h3:a ∪ b = (aᶜ ∩ bᶜ)ᶜ,
  { rw set.union_eq_compl_compl_inter_compl },
  rw h3,
  apply A.compl,
  apply A.inter,
  apply A.compl,
  apply h_a,
  apply A.compl,
  apply h_b,
end

lemma set.Union_succ {α:Type*} (j_n:ℕ) (f:ℕ → set α):
  (⋃ (i : ℕ) (h : i ≤ j_n.succ), f i) = (f j_n.succ) ∪ (⋃ (i : ℕ) (h : i ≤ j_n), f i) :=
begin
  ext a, split; intros h1; simp at h1; simp [h1],
  cases h1 with i h1,
  cases decidable.em (i = j_n.succ) with h2 h2,
  { subst i, simp [h1] },
  { right, apply exists.intro i,
    split,
    apply nat.le_of_lt_succ,
    rw lt_iff_le_and_ne, split,
    apply h1.left,
    apply h2, apply h1.right },
  cases h1 with h1 h1,
  { apply exists.intro j_n.succ,
    split, apply le_refl _,
    apply h1 },
  { cases h1 with i h1,
    apply exists.intro i,
    split,
    apply le_trans h1.left (le_of_lt (nat.lt_succ_self j_n)),
    apply h1.right },
end

lemma set.is_algebra.finite_union {α:Type*} {s : set (set α)} (A:s.is_algebra):
  (∀ (f:ℕ → (set α)), (∀ i, f i ∈ s) → (∀ j, (⋃ (i:ℕ) (h:i ≤ j), f i) ∈ s)) := begin
  intros f h3 j,
  induction j,
  { have h4:(⋃ (i : ℕ) (h : i ≤ 0), f i) = f 0,
   { ext a; split; intros h4_1, simp at h4_1, apply h4_1,
     simp, apply h4_1 }, rw h4, apply h3 },
  { rw set.Union_succ,
    apply A.union,
    apply h3,
    apply j_ih },
end

lemma set.monotone_class.compl {α:Type*} {s : set (set α)} :
  (∀ a ∈ s, aᶜ ∈ s) →
  (∀ (a:set α), s.monotone_class a → s.monotone_class aᶜ) := begin
  intros h1 a h2,
  induction h2 with a' h_a' f h_rec h_mono h_ind f h_rec h_mono h_ind,
  { apply set.monotone_class.basic,
    apply h1, apply h_a' },
  { rw set.compl_Inter,
    apply set.monotone_class.union,
    { intros n, apply h_ind },
    { apply @monotone_of_monotone_nat (set α) _ (λ (i : ℕ), (f i)ᶜ),
      intros n, simp, rw set.compl_subset_compl, apply h_mono } },
  { rw set.compl_Union,
    apply set.monotone_class.inter,
    { intros n, apply h_ind },
    { intros n, rw set.compl_subset_compl, apply h_mono, apply nat.le_of_lt,
      apply nat.lt_succ_self } },
end

lemma set.diff_Inter_eq_Union_diff {α:Type*} (a':set α) (f_b:ℕ → set α):
  a' \ (set.Inter f_b) = set.Union (λ i, a' \ (f_b i)) :=
begin
  ext ω, split; intros h5_1; simp at h5_1; simp [h5_1],
end

lemma set.Inter_diff_distrib {α:Type*} (a':set α) (f_b:ℕ → set α):
  (set.Inter f_b) \ a' = set.Inter (λ i, (f_b i) \ a') :=
begin
  ext ω, split; intros h5_1; simp at h5_1; simp [h5_1],
  apply (h5_1 0).right,
end

lemma set.diff_Union_eq_Inter_diff {α:Type*} (a':set α) (f_b:ℕ → set α):
  a' \ (set.Union f_b) = set.Inter (λ i, a' \ (f_b i)) :=
begin
  ext ω, split; intros h5_1; simp at h5_1; simp [h5_1],
  apply (h5_1 0).left,
end

lemma set.Union_diff_distrib {α:Type*} (a':set α) (f_b:ℕ → set α):
  (set.Union f_b) \ a' = set.Union (λ i, (f_b i) \ a') :=
begin
  ext ω, split; intros h5_1; simp at h5_1; simp [h5_1],
end

/- Effectively proves the monotone class of an algebra is an algebra. -/
lemma set.monotone_class.diff {α:Type*} {s : set (set α)} :
  (∀ a b, a∈ s → b ∈ s → a \ b ∈ s) →
  (∀ (a b:set α), s.monotone_class a → s.monotone_class b →
                  s.monotone_class (a \ b)) := begin
  intros h2 a b h3, revert b,
  induction h3 with a' h_a' f_a h_rec_a h_mono_a h_ind_a f_a h_rec_a
  h_mono_a h_ind_a,
  intros b h4,

  induction h4 with b' h_b' f_b h_rec_b h_mono_b h_ind_b f_b h_rec_b
  h_mono_b h_ind_b,
  { apply set.monotone_class.basic, apply h2, apply h_a', apply h_b' },
  { have h5:a' \ (set.Inter f_b) = set.Union (λ i, a' \ (f_b i)),
    { rw set.diff_Inter_eq_Union_diff },
    rw h5, apply set.monotone_class.union,
    { apply h_ind_b },
    { apply @monotone_of_monotone_nat (set α) _ (λ (i : ℕ), a' \ f_b i),
      intros n, simp, apply set.diff_subset_diff_right,
      apply h_mono_b } },
  { rw set.diff_Union_eq_Inter_diff,
    apply set.monotone_class.inter,
    { apply h_ind_b },
    { intros n,
      apply set.diff_subset_diff_right,
      apply h_mono_b,
      apply le_of_lt,
      apply nat.lt_succ_self } },
  { intros b h4,
    rw set.Inter_diff_distrib,
    apply set.monotone_class.inter,
    intros n,
    apply h_ind_a,
    apply h4,
    intros i,
    apply set.diff_subset_diff_left,
    apply h_mono_a },
  { intros b h4,
    rw set.Union_diff_distrib,
    apply set.monotone_class.union,
    { intros n, apply h_ind_a, apply h4 },
    intros i j h_le, simp, apply set.diff_subset_diff_left,
    apply h_mono_a, apply h_le },
end

lemma set.monotone_class.univ {α:Type*} {s : set (set α)} :
  (set.univ ∈ s) →
  (s.monotone_class set.univ) := begin
  intros h1,
  apply set.monotone_class.basic,
  apply h1
end

lemma set.is_algebra.monotone_class {α:Type*} {s : set (set α)} (A:s.is_algebra):
  set.is_algebra s.monotone_class := {
  univ := @set.monotone_class.univ α s (A.univ),
  diff := @set.monotone_class.diff α s (A.diff),
}

lemma set.monotone_class.pair_inter {α:Type*} {s : set (set α)} (A:s.is_algebra):
  (∀ (a b:set α), s.monotone_class a → s.monotone_class b →
                  s.monotone_class (a ∩ b)) := begin
  have AM := A.monotone_class,
  apply AM.inter,
end

lemma measurable_space.generate_measurable.inter {α:Type*} (s : set (set α)):
 ∀ f : ℕ → set α, (∀ n, measurable_space.generate_measurable s (f n)) →
  measurable_space.generate_measurable s (⋂ i, f i) :=
begin
  intros f h1,
  rw set.Inter_eq_comp_Union_comp,
  apply measurable_space.generate_measurable.compl,
  apply measurable_space.generate_measurable.union,
  intros n,
  apply measurable_space.generate_measurable.compl,
  apply h1,
end

/- The monotone class theorem (for sets) -/
lemma measurable_space.generate_from_monotone_class {α:Type*} (s : set (set α)) (A:s.is_algebra):
  (s.monotone_class = measurable_space.generate_measurable s) :=
begin
  have h3:∀ a ∈ s, aᶜ ∈ s,
  { apply  A.compl  },
  have h4:∅ ∈ s,
  { apply A.empty },
  have AM := A.monotone_class,

  ext a, split; intros h,
  { induction h with a' h_a' h_f h_rec h_mono h_ih,
    { apply measurable_space.generate_measurable.basic, apply h_a' },
    { apply measurable_space.generate_measurable.inter,
      intros n, apply h_ih },
    { apply measurable_space.generate_measurable.union,
      intros n, apply h_ih } },
  { induction h with a' h_a' a' h_a' h_ind f h_rec h_ind h_X4 h_X5,
    { apply set.monotone_class.basic, apply h_a' },
    { apply set.monotone_class.basic, apply h4 },
    { apply set.monotone_class.compl h3,
      apply h_ind },
    { let g:ℕ → set α := λ j, ⋃ (i:ℕ) (h:i ≤ j), (f i),
      begin
        have h7:set.Union f = set.Union g,
        { simp [g], ext a, split; intros h7_1;
          simp at h7_1; cases h7_1 with i h7_1;
          simp, existsi [i, i], simp [h7_1],
          cases h7_1 with j h7_1, existsi [j], simp [h7_1],  },
        rw h7,
        apply set.monotone_class.union,
        intros n,
        simp [g],
        apply AM.finite_union f,
        {apply h_ind },
        apply @monotone_of_monotone_nat (set α) _ g,
        intros n, simp [g],
        rw set.Union_succ,
        apply set.subset_union_right,
      end   },  },
end

def set.disjoint_union_closure {α:Type*} (S:set (set α)):set (set α) :=
  {s|∃ (m:ℕ) (f:fin m → set α), (∀ i, f i ∈ S) ∧ (pairwise (disjoint on f)) ∧ (s=(⋃ i, f i)) }

lemma set.mem_disjoint_union_closure_iff {α:Type*} (S:set (set α)) (s:set α):
  s ∈ S.disjoint_union_closure ↔
  (∃ (m:ℕ) (f:fin m → set α), (∀ i, f i ∈ S) ∧ (pairwise (disjoint on f)) ∧ (s=(⋃ i, f i))) := begin
  unfold set.disjoint_union_closure,
  simp,
end

lemma set.disjoint_union_closure_intro {α β:Type*} [fintype β] (S:set (set α)) (f:β → set α):
  (∀ b, f b ∈ S) →
  (pairwise (disjoint on f)) →
  (set.Union f) ∈ S.disjoint_union_closure := begin
  classical,
  intros h1 h2,
  simp [set.disjoint_union_closure],
  have h3:=fintype.exists_equiv_fin β,
  cases h3 with n h3,
  apply exists.intro n,
  let g := classical.choice h3,
  let h:fin n → set α := f ∘ g.inv_fun,
  begin
    apply exists.intro h,
    split,
    { intros i, simp [h,g,h1] },
    split,
    { intros i j h_ne,
      simp [function.on_fun, h],
      have h_ne2:g.symm i ≠ g.symm j,
      { simp, apply h_ne },
      have h_disj := h2 (g.symm i) (g.symm j) h_ne2,
      apply h_disj,
       },
    { ext ω, split; intros h4; simp at h4; cases h4 with i h4; simp [h4],
      { apply exists.intro (g i), simp [h, h4] },
      { apply exists.intro (g.symm i), apply h4  } },
  end
end

lemma set.disjoint_union_closure_self {α:Type*} (S:set (set α)) (s:set α):
  (s ∈ S) →
  (s∈ S.disjoint_union_closure) := begin
  let f:unit → (set α) := (λ _, s),
  begin
    intros h0,
    have h1:set.Union f = s,
    { simp [f], ext a, split; intros h1_1,
      simp at h1_1, apply h1_1,
      simp, apply h1_1 },
    rw ← h1,
    apply set.disjoint_union_closure_intro,
    intros n, simp [f, h0],
    intros i j h_ne,
    exfalso,
    apply h_ne,
    simp,
  end
end

structure set.is_semialgebra {α:Type*} (s:set (set α)) :=
  (univ : set.univ ∈ s)
  (empty : ∅ ∈ s)
  (inter : ∀ (a b:set α), a ∈ s → b ∈ s → a ∩ b ∈ s)
  (compl : ∀ (b:set α), b ∈ s → bᶜ ∈ s.disjoint_union_closure)

lemma set.disjoint_union_closure_inter {α:Type*} (S:set (set α)):
  (∀ (s t:set α), s ∈ S → t ∈ S → s ∩ t ∈ S) →
  (∀ (s t:set α), s ∈ S.disjoint_union_closure →
   t ∈ S.disjoint_union_closure → (s∩ t) ∈ S.disjoint_union_closure) := begin
  intros h1 s t h2 h3,
  simp [set.disjoint_union_closure] at h2,
  simp [set.disjoint_union_closure] at h3,
  cases h2 with m_s h2,
  cases h2 with f_s h2,
  cases h3 with m_t h3,
  cases h3 with f_t h3,
  cases h2 with h_in_s h2,
  cases h2 with h_pairwise_s h_def_s,
  subst s,
  cases h3 with h_in_t h3,
  cases h3 with h_pairwise_t h_def_t,
  subst t,
  let f:(fin m_s × fin m_t) → set α := (λ p, f_s p.fst ∩ f_t p.snd),
  begin
    have h4:set.Union f_s ∩ set.Union f_t  = set.Union f,
    { ext ω, split; intros h4_1; simp [f] at h4_1; cases h4_1 with h4_1 h4_2;
      cases h4_1 with i_s h4_1; cases h4_2 with i_t h4_2;
      simp [f]; split,
      { apply exists.intro i_s, apply h4_1 },
      { apply exists.intro i_t, apply h4_2 },
      { apply exists.intro i_s, apply h4_1 },
      { apply exists.intro i_t, apply h4_2 },
       },
   rw h4,
   apply set.disjoint_union_closure_intro,
   { intros p, simp [f], apply h1, apply h_in_s, apply h_in_t },
   { intros i j h_ne, simp [function.on_fun, f],
     rw disjoint_iff, simp, rw ← set.subset_empty_iff,
     have h_ne_alt:i.fst ≠ j.fst ∨ i.snd ≠ j.snd,
     { cases i, cases j, simp, cases classical.em (i_fst = j_fst) with h1 h1,
       { subst j_fst, right, intros contra, subst j_snd, apply h_ne, simp },
       simp [h1] },
     cases h_ne_alt with h_ne_fst h_ne_snd,
     { apply set.subset.trans, apply set.inter_subset_inter,
       apply set.inter_subset_left,
       apply set.inter_subset_left,
       have h_disj_s := h_pairwise_s i.fst j.fst h_ne_fst,
       simp [function.on_fun] at h_disj_s, rw disjoint_iff at h_disj_s, simp at h_disj_s,
       rw set.subset_empty_iff,
       apply h_disj_s },
     { apply set.subset.trans, apply set.inter_subset_inter,
       apply set.inter_subset_right,
       apply set.inter_subset_right,
       have h_disj_t := h_pairwise_t i.snd j.snd h_ne_snd,
       simp [function.on_fun] at h_disj_t, rw disjoint_iff at h_disj_t, simp at h_disj_t,
       rw set.subset_empty_iff,
       apply h_disj_t },
     },
  end
end

lemma set.disjoint_union_closure_univ {α:Type*} (S:set (set α)):
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
   (set.univ ∈ S.disjoint_union_closure) := begin
  intros h1 h2,
  rw ← set.compl_empty,
  apply h1,
  apply h2,
end

lemma set.disjoint_union_closure_finite_Inter_finset {α β:Type*} (S:set (set α))
  {f:β → set α} (T:finset β):
  (∀ (s t:set α), s ∈ S → t ∈ S → s ∩ t ∈ S) →
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
  (∀ (b:β), (f b) ∈ S.disjoint_union_closure) →
   ((⋂ i ∈ T, f i) ∈ S.disjoint_union_closure) := begin
  classical,
  intros h1 h2 h3 h4,
  have h5 := set.disjoint_union_closure_univ S h2 h3,
  apply finset.induction_on T,
  { simp, apply h5 },
  { intros a s h_a_notin_s h_ind,
    simp, apply set.disjoint_union_closure_inter S h1,
    apply h4, apply h_ind },
end

lemma set.disjoint_union_closure_finite_Inter {α β:Type*} [fintype β] (S:set (set α))
  {f:β → set α}:
  (∀ (s t:set α), s ∈ S → t ∈ S → s ∩ t ∈ S) →
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
  (∀ (b:β), (f b) ∈ S.disjoint_union_closure) →
   ((⋂ i, f i) ∈ S.disjoint_union_closure) := begin
  intros h1 h2 h3 h4,
  have h5:(⋂ i, f i) = (⋂ i ∈ finset.univ, f i),
  { ext a, split; intros h5_1; simp at h5_1; simp [h5_1],
    intros i, apply h5_1, apply finset.mem_univ },
  rw h5,
  apply @set.disjoint_union_closure_finite_Inter_finset α β S f finset.univ
    h1 h2 h3 h4,
end

lemma set.disjoint_union_closure_compl {α:Type*}  (S:set (set α)):
  (∀ (s t:set α), s ∈ S → t ∈ S → s ∩ t ∈ S) →
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
  (∀ s ∈ S.disjoint_union_closure, sᶜ ∈ S.disjoint_union_closure) := begin
  intros h1 h2 h3 s h4,
  rw set.mem_disjoint_union_closure_iff at h4,
  cases h4 with m h4,
  cases h4 with f h4,
  cases h4 with h4 h5,
  cases h5 with h5 h6,
  subst s,
  rw set.compl_Union,
  apply set.disjoint_union_closure_finite_Inter S h1 h2 h3,
  intros b, apply h2, apply h4,
  apply fin.fintype,
end

lemma set.disjoint_union_closure_diff {α:Type*}  (S:set (set α)):
  (∀ (s t:set α), s ∈ S → t ∈ S → s ∩ t ∈ S) →
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
  (∀ s t, s ∈ S.disjoint_union_closure → t ∈ S.disjoint_union_closure →
   (s \ t) ∈ S.disjoint_union_closure) := begin
  intros h1 h2 h3 s t h_s h_t,
  rw set.diff_eq,
  apply set.disjoint_union_closure_inter S h1,
  apply h_s,
  apply set.disjoint_union_closure_compl S h1 h2 h3,
  apply h_t,
end

/- A key connection. The closure of a semi-algebra is an algebra. -/
lemma set.is_semialgebra.disjoint_union_closure {α:Type*} {S:set (set α)} (A:S.is_semialgebra):
  S.disjoint_union_closure.is_algebra := {
  univ := set.disjoint_union_closure_univ S (A.compl) (A.empty),
  diff := set.disjoint_union_closure_diff S (A.inter) (A.compl) (A.empty),
}

lemma measurable_space.disjoint_union_encodable {α β:Type*} (S:set (set α))
  [E:encodable β] (f:β → (set α)):
  (∀ (b:β), f b ∈ S) →
  (pairwise (disjoint on f)) →
  (∅ ∈ S) →
  (∃ (g:ℕ → (set α)), (set.Union f = set.Union g) ∧ (pairwise (disjoint on g))
   ∧ (∀ i, g i ∈ S)) := begin
  intros h1 h2 h3,
  let g:ℕ → set α := λ (n:ℕ), (option.map f (encodable.decode2 β n)).get_or_else ∅,
  begin
    apply exists.intro g,
    split,
    ext1 ω, split; intros h4; simp [g] at h4; simp [h4, g]; cases h4 with i h4,
    { apply exists.intro (encodable.encode i),
      rw encodable.encodek2,
      simp [h4] },
    destruct (encodable.decode2 β i),
    { intros h5,
      rw h5 at h4,
      simp [option.map, option.get_or_else] at h4,
      exfalso, apply h4 },
    { intros b h6, rw h6 at h4,
      simp [option.map, option.get_or_else] at h4,
      apply exists.intro b,
      apply h4 },
    split,
    { intros i j h_ne,
      simp [function.on_fun, g],
      rw disjoint_iff,
      destruct (encodable.decode2 β i),
      { intros h7, simp [h7, option.map, option.get_or_else] },
      intros i_val h_i,
      simp [h_i, option.map, option.get_or_else],
      destruct (encodable.decode2 β j),
      { intros h8, simp [h8, option.map, option.get_or_else] },
      intros j_val h_j,
      simp [h_j, option.map, option.get_or_else],
      have h9: i_val ≠ j_val,
      { intros contra, apply h_ne,
        have h_partial:=@encodable.decode2_is_partial_inv β E,
        simp [function.is_partial_inv] at h_partial,
        subst j_val,
        rw h_partial at h_i,
        rw h_partial at h_j,
        rw ← h_i,
        rw ← h_j },
      have h10 := h2 i_val j_val h9,
      simp [function.on_fun, disjoint_iff] at h10,
      apply h10 },
    intros i,
    simp [g],
    cases (encodable.decode2 β i),
    repeat {simp [option.map, option.get_or_else, h3, h1]},
  end
end

lemma measurable_space.closure_union_Union {α:Type*} (S:set (set α)) (f:ℕ → (set α)):
  (∀ i, f i ∈ S.disjoint_union_closure) →
  (pairwise (disjoint on f)) →
  (∅ ∈ S) →
  (∃ (g:ℕ → (set α)), (set.Union f = set.Union g) ∧ (pairwise (disjoint on g))
    ∧ (∀ i, g i ∈ S)) := begin
  intros h1 h0,
  have h2 := (λ i, (set.mem_disjoint_union_closure_iff S (f i)).1 (h1 i)),
  rw classical.skolem at h2,
  cases h2 with m h2,
  have h3 := classical.axiom_of_choice h2,
  cases h3 with f' h3,
  let f'':(Σ (i:ℕ), fin (m i)) → set α := λ p, f' (p.fst) (p.snd),
  begin
    have h4:set.Union f'' = set.Union f,
    { ext, split; intros h4_1; simp [f''] at h4_1; simp [f'']; cases h4_1 with i h4_1;
      apply exists.intro i; have h4_2 := (h3 i).right.right,
      { cases h4_1 with b h4_1,
        rw h4_2, simp, apply exists.intro b,
        apply h4_1 },
      { rw h4_2 at h4_1,
        simp at h4_1,
        cases h4_1 with b h4_2,
        apply exists.intro b,
        apply h4_2 },
        },
    rw ← h4,
    have h6:∀ i, ∀ (j:fin (m i)), f'' (sigma.mk i j) ⊆ f i,
    { intros i j, simp [f''], rw (h3 i).right.right,  simp,
      have h6_1:f' (sigma.mk i j).fst j = f' i j := rfl,
      rw h6_1, apply set.subset_Union },
    apply measurable_space.disjoint_union_encodable,
    { intros b, have h5 := (h3 b.fst).left b.snd,
      apply h5 },
    intros i j h_ne,
    cases i, cases j,
    simp at h_ne,
    simp [function.on_fun],
    rw disjoint_iff,
    simp [f''],
    cases classical.em (i_fst = j_fst) with h5 h5,
    { have h_ne_snd := h_ne h5,
      subst j_fst,
      have h_ne_snd2:i_snd ≠ j_snd,
      { intros contra, apply h_ne_snd, rw contra },
      have h_disj := (h3 i_fst).right.left i_snd j_snd h_ne_snd2,
      simp [function.on_fun] at h_disj, rw disjoint_iff at h_disj,  simp at h_disj,
      apply h_disj },
    { rw ← set.subset_empty_iff,
      apply set.subset.trans,
      apply set.inter_subset_inter,
      apply h6, apply h6,
      have h7 := h0 i_fst j_fst h5,
      simp [function.on_fun] at h7,
      rw disjoint_iff at h7, simp at h7, simp [h7] },
  end
end

lemma set.disjoint_union_closure_Inter {α:Type*} (S:set (set α))
  (f:ℕ → (set α)) (j:ℕ):
  (∀ s t∈ S, s ∩ t ∈ S) →
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
  (∀ i, f i ∈ S.disjoint_union_closure) →
  ((⋂ (i_1 : ℕ) (H : i_1 < j), f i_1) ∈ S.disjoint_union_closure) := begin
  intros h1 h2 h3 h4,
  induction j,
  { simp, rw ← set.compl_empty, apply h2, apply h3 },
  { have h5:(⋂ (i_1 : ℕ) (H : i_1 < j_n.succ), f i_1) =
    (f j_n) ∩ (⋂ (i_1 : ℕ) (H : i_1 < j_n), f i_1),
    { ext a, split; intros h5_1; simp at h5_1; simp,
      split,
      apply h5_1,
      apply nat.lt_succ_self,
      intros i h5_2,
      apply h5_1,
      apply lt_trans h5_2,
      apply nat.lt_succ_self,
      intros i h5_2,
      cases classical.em (i = j_n) with h5_3 h5_3,
      subst i,
      apply h5_1.left,
      apply h5_1.right,
      rw lt_iff_le_and_ne,
      split,
      rw ← nat.lt_succ_iff,
      apply h5_2,
      apply h5_3 },
    rw h5,
    apply set.disjoint_union_closure_inter,
    apply h1,
    apply h4,
    apply j_ih },
end

lemma measurable_space.union_to_disjoint {α:Type*} (S:set (set α)) (f:ℕ → (set α)):
  (∀ s t∈ S, s ∩ t ∈ S) →
  (∀ s ∈ S, sᶜ ∈ S.disjoint_union_closure) →
  (∅ ∈ S) →
  (∀ i, f i ∈ S) →
  (∃ (g:ℕ → (set α)), (set.Union f = set.Union g) ∧ (pairwise (disjoint on g))
    ∧ (∀ i, g i ∈ S)) := begin
  intros h1 h2 h3 h4,
  have h5:∃ f':ℕ → set α, (set.Union f = set.Union f') ∧ (∀ i, f' i ∈ S.disjoint_union_closure) ∧
  (pairwise (disjoint on f')),
  { apply exists.intro (set.disjointed f),
    split,
    rw set.Union_disjointed,
    rw and.comm,
    split,
    apply set.disjoint_disjointed,
    intros i,
    simp [set.disjointed],
    apply set.disjoint_union_closure_inter,
    apply h1,
    apply set.disjoint_union_closure_self,
    apply h4,
    apply set.disjoint_union_closure_Inter,
    apply h1, apply h2,
    apply h3,
    intros i,
    apply h2,
    apply h4 },
  cases h5 with f' h5,
  rw h5.left,
  apply measurable_space.closure_union_Union S f' h5.right.left h5.right.right,
  apply h3,
end


import tactic --hide

/-Lemma
For any logical statement $P$, $(\mathrm{true} \implies \mathrm{false})$ implies $P$.
-/
lemma true_to_false_imp_P (P : Prop) : (true → false) → P :=
begin
 intro h,
 exfalso,
 apply h,
 triv,

end


import ..mcrl2_encap.mcrl2_encap

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]
variable {β : Type}

/- The relation used to prove congruence of the summation operator.-/
inductive R_sum {f g} {D : set β} (R_α : ∀a, a ∈ D → mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R {x y a} {ha} (h : R_α a ha x y) : R_sum x y
| basel : R_sum (sum D f) (sum D g)
| baser : R_sum (sum D g) (sum D f)
| stepl {d}
  (h₁ : R_sum (sum D f) (sum D g)) (h₁ : R_sum (sum D g) (sum D f))
  (h₂: d ∈ D) :
  R_sum (f d) (g d)
| stepr {d}
  (h₁ : R_sum (sum D f) (sum D g)) (h₁ : R_sum (sum D g) (sum D f))
  (h₂: d ∈ D) :
  R_sum (g d) (f d)

lemma R_sum.symm {f g} {D : set β} (R_α : ∀a, a ∈ D → mcrl2 α → mcrl2 α → Prop)
  (R_α_symm : ∀a ha, symmetric (R_α a ha)) :
symmetric (@R_sum α _ β f g D R_α) :=
begin
  intros x y h,
  cases h,
  { apply R_sum.R,
    apply R_α_symm,
    assumption},
  { apply R_sum.baser},
  { apply R_sum.basel},
  { apply R_sum.stepr; assumption},
  { apply R_sum.stepl; assumption}
end

lemma bisim.sum {f g : β → mcrl2 α} {D} (h : ∀a, a ∈ D → f a ≈ g a) :
sum D f ≈ sum D g :=
begin
  choose R R₁x R_bisim using h,
  apply exists.intro (R_sum R),
  apply and.intro,
  exact R_sum.basel,
  apply and.intro,
  { intros x y x' a h₁ h₂,
    cases h₁,
    { have h : (∃y', transition y a y' ∧ option.rel (R h₁_a h₁_ha) x' y'),
      by exact bisim_lift (R_bisim h₁_a h₁_ha) h₁_h h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply and.intro haw,
      apply option.rel.mono _ hRw,
      intros x y,
      apply R_sum.R},
    { cases h₂,
      simp [transition.sum_iff, ←exists_and_distrib_right, and_assoc],
      have h : (∃y', transition (g h₂_a') a y' ∧ option.rel (R h₂_a' h₂_ha') x' y'),
      by exact bisim_lift (R_bisim h₂_a' h₂_ha') (R₁x h₂_a' h₂_ha') h₂_h,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply exists.intro h₂_a',
      apply and.intro h₂_ha',
      apply and.intro haw,
      apply option.rel.mono _ hRw,
      intros x y,
      exact R_sum.R},
    { cases h₂,
      simp [transition.sum_iff, ←exists_and_distrib_right, and_assoc],
      have h : (∃y', transition (f h₂_a') a y' ∧ option.rel (R h₂_a' h₂_ha') x' y'),
      by exact bisim_lift (R_bisim h₂_a' h₂_ha') ((R_bisim h₂_a' h₂_ha').right (R₁x h₂_a' h₂_ha')) h₂_h,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply exists.intro h₂_a',
      apply and.intro h₂_ha',
      apply and.intro haw,
      apply option.rel.mono _ hRw,
      intros x y,
      exact R_sum.R},
    { have h : (∃y', transition (g h₁_d) a y' ∧ option.rel (R h₁_d h₁_h₂) x' y'),
      by exact bisim_lift (R_bisim h₁_d h₁_h₂) (R₁x h₁_d h₁_h₂) h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply and.intro haw,
      apply option.rel.mono _ hRw,
      intros x y,
      exact R_sum.R},
    { have h : (∃y', transition (f h₁_d) a y' ∧ option.rel (R h₁_d h₁_h₂) x' y'),
      by exact bisim_lift (R_bisim h₁_d h₁_h₂) ((R_bisim h₁_d h₁_h₂).right (R₁x h₁_d h₁_h₂)) h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply and.intro haw,
      apply option.rel.mono _ hRw,
      intros x y,
      exact R_sum.R}},
    { choose R_bisim R_symm using R_bisim,
      exact R_sum.symm R R_symm}
end