namespace hidden

inductive nat
| zero : nat
| succ : nat → nat
| pred : nat → nat

notation 0 := nat.zero
notation `S` := nat.succ
notation `P` := nat.pred
notation 1 := S 0
axiom succ_pred : ∀ n : nat, S (P n) = n

example : S (P 0) = 0 := succ_pred _ -- <=> succ_pred 0

lemma pred_succ_zero : P (S 0) = 0 :=
begin
  have h := λ(n m : nat)(f : nat → nat), n = m → f n = f m,
  type_check (h 0 0 (λ n, S n)), -- Prop
  have h2 : ∀ (n m : nat)(f : nat → nat), n = m → f n = f m := sorry,
  type_check h2 0 1 (λ n, n),

  have h3 := h2 0 0 (λ n, n),
  simp at h3,
  clear h3,
end

end hidden

example : true := true.intro

lemma test : (1 : hidden.nat) = 1 ∧ 2 = 2 :=
begin
  -- apply and.intro,
  -- exact eq.refl 1,
  -- exact eq.refl 2,

  -- apply ⟨eq.refl _, _⟩, -- invalid constructor ⟨...⟩
  refine ⟨eq.refl _, _⟩, -- 1 goal ⊢ 2 = 2
   -- rfl <=> eq.refl _, but with imlicit types: @rfl type value
  exact @rfl nat 2,
end

#print test

#check nat.succ


import .basic

namespace hidden

-- Can't extend field and ordered_myring as they both extend myring >:(
class ordered_myfield (α : Type) extends myfield α, has_le α:=
-- NOTE: Theses are the ordered_myring axioms
(f_decidable_le: ∀ a b: α, decidable (a ≤ b))
(f_le_add_right (a b c : α) : a ≤ b → a + c ≤ b + c)
(f_zero_le_mul (a b : α) : 0 ≤ a → 0 ≤ b → 0 ≤ a * b)
(f_le_trans (a b c: α): a ≤ b → b ≤ c → a ≤ c)
(f_le_total_order (a b: α): a ≤ b ∨ b ≤ a)
(f_le_antisymm (a b: α): a ≤ b → b ≤ a → a = b)

namespace ordered_myfield

open myfield
open myring
open ordered_myring

variables {α : Type} [ordered_myfield α] (x y z : α)

-- This is peak L∃∀N
instance : ordered_integral_domain α := {
  oid_decidable_le := f_decidable_le,
  oid_le_add_right := f_le_add_right,
  oid_zero_le_mul := f_zero_le_mul,
  oid_le_trans := f_le_trans,
  oid_le_total_order := f_le_total_order,
  oid_le_antisymm := f_le_antisymm
}

theorem half_pos {ε : α} : 0 < ε → 0 < ε / 2 := sorry
-- assume h, by rwa [lt_mul_pos_right zero_lt_two, zero_mul, div_mul_cancel two_nzero]

theorem pos_impl_inv_pos {x : α} : 0 < x → 0 < x⁻¹ := sorry

theorem exists_between (a c : α) :
a < c → ∃ b : α, a < b ∧ b < c :=
begin
  assume hac,
  existsi (a + c) * (2 : α)⁻¹,
  split; rw add_mul, {
    conv {
      to_lhs,
      rw ←mul_one a,
    },
    rw lt_add_cancel_left _ _ (a * -2⁻¹),
    -- WTF is going on here?
    sorry,
    -- rw [lt_add_left (-(a/2)), ←add_assoc, add_comm _ a, neg_self_add],
    -- conv {
    --   to_lhs,
    --   congr,
    --     rw ←@half_plus_half a, skip,
    --   skip,
    -- },
    -- rw [add_assoc, self_neg_add, add_zero, zero_add],
    -- rwa [lt_mul_pos_right zero_lt_two, div_mul_cancel two_nzero,
    --      div_mul_cancel two_nzero],
  }, {
    sorry,
    -- rw [lt_add_right (-(c / 2)), add_assoc, self_neg_add],
    -- conv {
    --   to_rhs,
    --   congr,
    --     rw ←@half_plus_half c, skip,
    --   skip,
    -- },
    -- rw [add_assoc, self_neg_add, add_zero, add_zero],
    -- rwa [lt_mul_pos_right zero_lt_two, div_mul_cancel two_nzero,
    --      div_mul_cancel two_nzero],
  },
end

-- theorem lt_mul_comb_nonneg (a b x y : α): 0 ≤ a → 0 ≤ x → a < b → x < y → a * x < b * y :=
-- begin
--   assume h0a h0x hab hxy haxby,
--   have := le_mul_comb_nonneg _ _ _ _ h0a h0x
--     (lt_impl_le _ _ hab) (lt_impl_le _ _ hxy),
--   have has := le_antisymm _ _ haxby this,
--   clear haxby this,
--   have h1: x * (b - a) + b * (y - x) = 0, {
--     repeat {rw mul_sub},
--     rw has,
--     repeat {rw mul_comm _ x},
--     rw add_comm,
--     change x * a + -(x * b) + (x * b + -(x * a)) = 0,
--     rw add_assoc,
--     rw add_comm,
--     repeat {rw add_assoc},
--     rw neg_add,
--     rw add_zero,
--     rw neg_add,
--   },
--   have h2: 0 ≤ x * (b - a), {
--     rw lt_iff_diff_pos at hab,
--     have := le_mul_comb_nonneg _ _ _ _ (le_refl _) (le_refl _) h0x
--       (lt_impl_le _ _ hab),
--     rw zero_mul at this,
--     assumption,
--   },
--   have h3: 0 < b * (y - x), {
--     rw lt_iff_diff_pos at hxy,
--     from zero_lt_mul _ _ (le_lt_chain _ h0a hab) hxy,
--   },
--   have := lt_le_comb h3 h2,
--   rw add_zero at this,
--   rw add_comm at this,
--   rw h1 at this,
--   from lt_nrefl _ this,
-- end

-- private lemma inv_pos: 0 < a → 0 < a⁻¹ :=
-- begin
--   assume h0x,
--   assume hxi0,
--   by_cases h: 0 ≤ a⁻¹, {
--     have := le_antisymm hxi0 h,
--     have hx0: a = 0, {
--       rw ←@inv_inv a,
--       rw this,
--       refl,
--     },
--     subst hx0,
--     from lt_nrefl _ h0x,
--   }, {
--     rw ←lt_iff_nle at h,
--     rw lt_neg_switch at h,
--     rw neg_zero at h,
--     have := zero_lt_mul _ _ h0x h,
--     rw mul_with_neg at this,
--     rw mul_comm at this,
--     rw inv_self_mul at this,
--     rw lt_neg_switch at this,
--     rw neg_zero at this,
--     rw neg_neg at this,
--     from this zero_le_one,
--     assume hc,
--     from lt_impl_ne h0x hc.symm,
--  },
-- end

-- theorem pos_iff_inv_pos : 0 < a ↔ 0 < a⁻¹ :=
-- begin
--   split, {
--     from inv_pos a,
--   }, {
--     have := inv_pos a⁻¹,
--     rw inv_inv at this,
--     assumption,
--   },
-- end

end ordered_myfield

end hidden


import inner_product_spaces.real_ip.ip_normed_space

set_option class.instance_max_depth 100

noncomputable theory

open real linear_map

section cartesian_prod

variables {α : Type*} {β : Type*}
variables [decidable_eq α] [add_comm_group α] [vector_space ℝ α] [ℝ_inner_product_space α]
variables [decidable_eq β] [add_comm_group β] [vector_space ℝ β] [ℝ_inner_product_space β]

@[reducible] def prod_inner_product (x y : α×β) : ℝ := ⟪x.1 ∥ y.1⟫ + ⟪x.2 ∥ y.2⟫

@[reducible] instance prod_has_inner_product : has_ℝ_inner_product (α×β) := ⟨prod_inner_product⟩

lemma prod_conj_symm (x y : α × β) : ⟪x ∥ y⟫ = ⟪y ∥ x⟫ :=
by {dsimp [inner_product, prod_inner_product],
    rw [conj_symm x.fst, conj_symm x.snd]}

lemma prod_linearity (x y z : α × β) (a : ℝ) : ⟪a • x + y ∥ z⟫ = a * ⟪x ∥ z⟫ + ⟪y ∥ z⟫ :=
begin
    dsimp [inner_product, prod_inner_product],
    simp [-add_comm, add_comm],
    simp,
    rw [left_distrib],
end

lemma comp_neq_zero_of_neq_zero (x : α × β) : x ≠ 0 → x.1 ≠ 0 ∨ x.2 ≠ 0 :=
begin
    rw [awesome_mt],
    simp [not_or_distrib],
    intros a b,
    rw [←@prod.mk.eta _ _ x, a, b],
    refl,
end

lemma prod_pos_def (x : α × β) (h : x ≠ 0) : ⟪x ∥ x⟫ > 0 :=
begin
    dsimp [inner_product, prod_inner_product],
    have w := comp_neq_zero_of_neq_zero _ h,
    cases w,

    exact lt_add_of_pos_of_le (pos_def _ w) (norm_sq_nonneg x.2),

    exact lt_add_of_le_of_pos (norm_sq_nonneg x.1) (pos_def _ w),
end

instance prod_inner_product_space : ℝ_inner_product_space (α×β) :=
{conj_symm := prod_conj_symm, linearity := prod_linearity, pos_def := prod_pos_def}

end cartesian_prod

section real_ip

@[reducible] instance ℝ_has_ℝ_inner_product : has_ℝ_inner_product ℝ := ⟨λ a b, a*b⟩

lemma ℝ_conj_symm (x y : ℝ) : ⟪x ∥ y⟫ = ⟪y ∥ x⟫ := mul_comm x y

lemma ℝ_linearity (x y z : ℝ) (a : ℝ) : ⟪a•x+y ∥ z⟫ = a*⟪x ∥ z⟫ + ⟪y ∥ z⟫ :=
by {dsimp [inner_product], rw [right_distrib, mul_assoc]}

lemma ℝ_pos_def (x : ℝ) : x ≠ 0 → ⟪x ∥ x⟫ > 0 := mul_self_pos

instance ℝ_is_ℝ_inner_product_space : ℝ_inner_product_space ℝ :=
{conj_symm := ℝ_conj_symm, linearity := ℝ_linearity, pos_def := ℝ_pos_def}

end real_ip

open function

section inj_linear_map

variables {γ : Type*} [decidable_eq γ] [add_comm_group γ] [vector_space ℝ γ] [ℝ_inner_product_space γ]
variables {η : Type*} [decidable_eq η] [add_comm_group η] [vector_space ℝ η]
variables (f : linear_map ℝ η γ) (h : injective f.to_fun)

lemma fun_coe (f : linear_map ℝ η γ) : ⇑f = f.to_fun := rfl

include f h

@[reducible] instance inj_has_inner_product : has_ℝ_inner_product η := ⟨λ x y, ⟪f.to_fun x ∥ f.to_fun y⟫⟩

lemma inj_conj_symm (x y : η) : ⟪f.to_fun x ∥ f.to_fun y⟫ = ⟪f.to_fun y ∥ f.to_fun x⟫ := conj_symm (f.to_fun x) (f.to_fun y)

lemma inj_linearity (x y z : η) (a : ℝ) : ⟪f.to_fun (a • x + y) ∥ f.to_fun z⟫ = a * ⟪f.to_fun x ∥ f.to_fun z⟫ + ⟪f.to_fun y ∥ f.to_fun z⟫ :=
by {rw [add, smul],
    exact linearity (f.to_fun x) (f.to_fun y) (f.to_fun z) a}

lemma trivial_ker_of_injective (x : η) (k : f.to_fun x = 0) : x = 0 :=
begin
    have w := map_zero f,
    dsimp [injective] at h,
    rw [←w, fun_coe f] at k,
    exact (h k),
end

lemma inj_pos_def (x : η) : x ≠ 0 → ⟪f.to_fun x ∥ f.to_fun x⟫ > 0 :=
begin
    rw [awesome_mt],
    simp,
    have w := norm_sq_nonneg (f.to_fun x),
    have k₁ := zero_iff_norm_sq_zero (f.to_fun x),
    dsimp [norm_sq] at *,
    intros k,
    have w₁ := antisymm w k,
    have w₂ := k₁.1 w₁,
    exact (trivial_ker_of_injective f h x w₂),
end

instance inj_inner_product_space (f : linear_map ℝ η γ) (h : injective f.to_fun) : ℝ_inner_product_space η :=
begin
    refine_struct {..},

    use λ x y, ⟪f.to_fun x ∥ f.to_fun y⟫,

    exact inj_conj_symm f h,

    exact inj_linearity f h,

    exact inj_pos_def f h,
end

end inj_linear_map

section subspace

variables {γ : Type*} [decidable_eq γ] [add_comm_group γ] [vector_space ℝ γ] [ℝ_inner_product_space γ]
variables {η : subspace ℝ γ}

def realise : linear_map ℝ η γ :=
begin
    refine_struct {..},
    use λ x, x,
    repeat {simp},
end

lemma realise_injective : @injective ↥η γ (realise.to_fun) :=
begin
    dsimp [injective, realise],
    intros x₁ x₂ k,
    exact set_coe.ext k,
end

instance sub_inner_product_space : ℝ_inner_product_space η :=
inj_inner_product_space realise realise_injective

end subspace


lemma one_mul (m : mynat) : 1 * m = m :=
begin
induction m with a ha,
rw mul_zero,
refl,
rw mul_succ,
rw ha,
rw succ_eq_add_one,
refl,
end


import algebra.homology.additive
import algebra.homology.homological_complex

import for_mathlib.free_abelian_group
import for_mathlib.FreeAb

import breen_deligne.universal_map

/-!

# The category of Breen-Deligne data

This file defines the category whose objects are the natural numbers
and whose morphisms `m ⟶ n` are functorial maps `φ_A : ℤ[A^m] → ℤ[A^n]`.

-/

open_locale big_operators kronecker

namespace breen_deligne

open free_abelian_group category_theory

/-- The category whose objects are natural numbers
and whose morphisms are matrices with integer coefficients. -/
@[derive comm_semiring] def Mat := ℕ

namespace Mat

instance : small_category Mat :=
{ hom := λ m n, basic_universal_map m n,
  id := basic_universal_map.id,
  comp := λ l m n f g, basic_universal_map.comp g f,
  id_comp' := λ n f, basic_universal_map.comp_id,
  comp_id' := λ n f, basic_universal_map.id_comp,
  assoc' := λ k l m n f g h, (basic_universal_map.comp_assoc h g f).symm }

end Mat

/-- The category whose objects are natural numbers
and whose morphisms are the free abelian groups generated by
matrices with integer coefficients. -/
@[derive comm_semiring] def FreeMat := ℕ

namespace FreeMat

instance : small_category FreeMat :=
{ hom := λ m n, universal_map m n,
  id := universal_map.id,
  comp := λ l m n f g, universal_map.comp g f,
  id_comp' := λ n f, universal_map.comp_id,
  comp_id' := λ n f, universal_map.id_comp,
  assoc' := λ k l m n f g h, (universal_map.comp_assoc h g f).symm }

instance : preadditive FreeMat :=
{ hom_group := λ m n, infer_instance,
  add_comp' := λ l m n f g h, add_monoid_hom.map_add _ _ _,
  comp_add' := λ l m n f g h, show universal_map.comp (g + h) f = _,
    by { rw [add_monoid_hom.map_add, add_monoid_hom.add_apply], refl } }

def to_FreeAbMat : FreeMat ⥤ FreeAb Mat :=
{ obj := λ n, FreeAb.of n,
  map := λ m n f, f,
  map_id' := λ m, rfl,
  map_comp' := λ l m n f g, begin
    induction f using free_abelian_group.induction_on;
    try { simp only [limits.zero_comp, preadditive.add_comp, preadditive.neg_comp, *] },
    induction g using free_abelian_group.induction_on;
    try { simp only [limits.comp_zero, preadditive.comp_add, preadditive.comp_neg, *] },
    refl,
  end }

open universal_map

@[simps]
def mul_functor (N : ℕ) : FreeMat ⥤ FreeMat :=
{ obj := λ n, N * n,
  map := λ m n f, mul N f,
  map_id' := λ n, (free_abelian_group.map_of _ _).trans $ congr_arg _ $
  begin
    dsimp [basic_universal_map.mul, basic_universal_map.id],
    ext i j,
    simp only [matrix.one_kronecker_one, matrix.submatrix_apply, matrix.one_apply,
      equiv.apply_eq_iff_eq, eq_self_iff_true],
  end,
  map_comp' := λ l m n f g, mul_comp _ _ _ }
.
instance mul_functor.additive (N : ℕ) : (mul_functor N).additive :=
{ map_add' := λ m n f g, add_monoid_hom.map_add _ _ _ }

@[simps] def iso_mk' {m n : FreeMat}
  (f : basic_universal_map m n) (g : basic_universal_map n m)
  (hfg : basic_universal_map.comp g f = basic_universal_map.id _)
  (hgf : basic_universal_map.comp f g = basic_universal_map.id _) :
  m ≅ n :=
{ hom := of f,
  inv := of g,
  hom_inv_id' := (comp_of _ _).trans $ congr_arg _ $ hfg,
  inv_hom_id' := (comp_of _ _).trans $ congr_arg _ $ hgf }

def one_mul_iso : mul_functor 1 ≅ 𝟭 _ :=
nat_iso.of_components (λ n, iso_mk'
  (basic_universal_map.one_mul_hom _) (basic_universal_map.one_mul_inv _)
  basic_universal_map.one_mul_inv_hom basic_universal_map.one_mul_hom_inv)
begin
  intros m n f,
  dsimp,
  show universal_map.comp _ _ = universal_map.comp _ _,
  rw [← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_hom_apply_apply,
    ← add_monoid_hom.flip_apply _ f],
  congr' 1, clear f, ext1 f,
  have : f = matrix.reindex_linear_equiv ℕ _
      ((fin_one_equiv.prod_congr $ equiv.refl _).trans $ equiv.punit_prod _)
      ((fin_one_equiv.prod_congr $ equiv.refl _).trans $ equiv.punit_prod _)
      (1 ⊗ₖ f),
  { ext i j, dsimp [matrix.kronecker, matrix.one_apply],
    simp only [one_mul, if_true, eq_iff_true_of_subsingleton], },
  conv_rhs { rw this },
  simp only [comp_of, mul_of, basic_universal_map.comp, add_monoid_hom.mk'_apply,
    basic_universal_map.mul, basic_universal_map.one_mul_hom,
    add_monoid_hom.comp_hom_apply_apply, add_monoid_hom.comp_apply, add_monoid_hom.flip_apply,
    iso_mk'_hom],
  rw [matrix.reindex_linear_equiv_mul, matrix.reindex_linear_equiv_mul,
    matrix.one_mul, matrix.mul_one],
end

/-
Should `kronecker_reindex_left` and `kronecker_reindex_right` land into `mathlib`?
-/

variables {α β γ : Type*}
variables {l₁ m₁ n₁ l₂ m₂ n₂ : Type*}
variables [fintype l₁] [fintype m₁] [fintype n₁]
variables [fintype l₂] [fintype m₂] [fintype n₂]

lemma kronecker_map_reindex_left (f : α → β → γ) (el : l₁ ≃ l₂) (em : m₁ ≃ m₂) (M : matrix l₁ m₁ α)
  (N : matrix n₁ n₂ β) : matrix.kronecker_map f (matrix.reindex el em M) N =
  matrix.reindex (el.prod_congr (equiv.refl _)) (em.prod_congr (equiv.refl _))
  (matrix.kronecker_map f M N) := by { ext ⟨i, i'⟩ ⟨j, j'⟩, refl }

lemma kronecker_map_reindex_right (f : α → β → γ) (em : m₁ ≃ m₂) (en : n₁ ≃ n₂)
  (M : matrix l₁ l₂ α) (N : matrix m₁ n₁ β) :
  matrix.kronecker_map f M (matrix.reindex em en N) =
  matrix.reindex ((equiv.refl _).prod_congr em) ((equiv.refl _).prod_congr en)
    (matrix.kronecker_map f M N) := by { ext ⟨i, i'⟩ ⟨j, j'⟩, refl }

lemma mul_mul_iso_aux (m n i j : ℕ) (f : basic_universal_map i j) :
  (comp (of (basic_universal_map.mul_mul_hom m n j))) (mul m (mul n (of f))) =
    comp (mul (m * n) (of f)) (of (basic_universal_map.mul_mul_hom m n i)) :=
begin
  simp only [comp_of, mul_of, basic_universal_map.comp, add_monoid_hom.mk'_apply,
    basic_universal_map.mul, basic_universal_map.mul_mul_hom, matrix.mul_reindex_linear_equiv_one],
  rw [matrix.reindex_linear_equiv_mul, matrix.one_mul,
    ← matrix.reindex_linear_equiv_one ℕ _ (@fin_prod_fin_equiv m n)],
  simp only [matrix.reindex_linear_equiv_apply],
  rw [kronecker_map_reindex_left, kronecker_map_reindex_right, ← matrix.kronecker_assoc],
  simp only [← equiv.trans_apply, matrix.reindex_trans, matrix.one_kronecker_one,
    equiv.trans_refl],
  congr' 3, swap 3, { apply_instance },
  { ext ⟨⟨a, b⟩, c⟩,
    simp only [equiv.trans_apply, equiv.symm_apply_apply, equiv.apply_symm_apply,
      equiv.prod_assoc_apply, equiv.prod_assoc_symm_apply, equiv.prod_congr_apply,
      prod.map_def, equiv.refl_apply], },
  { ext ⟨⟨a, b⟩, c⟩,
    simp only [equiv.trans_apply, equiv.symm_apply_apply, equiv.apply_symm_apply,
      equiv.prod_assoc_apply, equiv.prod_assoc_symm_apply, equiv.prod_congr_apply,
      prod.map_def, equiv.refl_apply, equiv.symm_trans_apply, equiv.symm_symm,
      equiv.prod_congr_symm, equiv.refl_symm], },
end

def mul_mul_iso (m n : ℕ) : mul_functor n ⋙ mul_functor m ≅ mul_functor (m * n) :=
nat_iso.of_components (λ i, iso_mk'
  (basic_universal_map.mul_mul_hom m n i) (basic_universal_map.mul_mul_inv m n i)
  basic_universal_map.mul_mul_inv_hom basic_universal_map.mul_mul_hom_inv)
begin
  intros i j f,
  dsimp,
  show universal_map.comp _ _ = universal_map.comp _ _,
  rw [← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_apply,
    ← add_monoid_hom.flip_apply _ (mul (m * n) f),
    ← add_monoid_hom.comp_apply],
  congr' 1, clear f, ext1 f,
  apply mul_mul_iso_aux,
end

end FreeMat

/-- Roughly speaking, this is a collection of formal finite sums of matrices
that encode the data that rolls out of the Breen--Deligne resolution. -/
@[derive [small_category, preadditive]]
def data := chain_complex FreeMat ℕ

namespace data

variable (BD : data)

section mul

open universal_map

@[simps]
def mul (N : ℕ) : data ⥤ data :=
(FreeMat.mul_functor N).map_homological_complex _

def mul_one_iso : (mul 1).obj BD ≅ BD :=
homological_complex.hom.iso_of_components (λ i, FreeMat.one_mul_iso.app _) $
λ i j _, (FreeMat.one_mul_iso.hom.naturality (BD.d i j)).symm

def mul_mul_iso (m n : ℕ) : (mul m).obj ((mul n).obj BD) ≅ (mul (m * n)).obj BD :=
homological_complex.hom.iso_of_components (λ i, (FreeMat.mul_mul_iso _ _).app _) $
λ i j _, ((FreeMat.mul_mul_iso _ _).hom.naturality (BD.d i j)).symm

end mul

/-- `BD.pow N` is the Breen--Deligne data whose `n`-th rank is `2^N * BD.rank n`. -/
def pow' : ℕ → data
| 0     := BD
| (n+1) := (mul 2).obj (pow' n)

@[simps] def sum (BD : data) (N : ℕ) : (mul N).obj BD ⟶ BD :=
{ f := λ n, universal_map.sum _ _,
  comm' := λ m n _, (universal_map.sum_comp_mul _ _).symm }

@[simps] def proj (BD : data) (N : ℕ) : (mul N).obj BD ⟶ BD :=
{ f := λ n, universal_map.proj _ _,
  comm' := λ m n _, (universal_map.proj_comp_mul _ _).symm }

open homological_complex FreeMat category_theory category_theory.limits

def hom_pow' {BD : data} (f : (mul 2).obj BD ⟶ BD) : Π N, BD.pow' N ⟶ BD
| 0     := 𝟙 _
| (n+1) := (mul 2).map (hom_pow' n) ≫ f

open_locale zero_object

def pow'_iso_mul : Π N, BD.pow' N ≅ (mul (2^N)).obj BD
| 0     := BD.mul_one_iso.symm
| (N+1) := show (mul 2).obj (BD.pow' N) ≅ (mul (2 * 2 ^ N)).obj BD, from
   (mul 2).map_iso (pow'_iso_mul N) ≪≫ mul_mul_iso _ _ _

lemma hom_pow'_sum : ∀ N, (BD.pow'_iso_mul N).inv ≫ hom_pow' (BD.sum 2) N = BD.sum (2^N)
| 0     :=
begin
  ext n : 2,
  simp only [hom_pow', category.comp_id],
  show (BD.pow'_iso_mul 0).inv.f n = (BD.sum 1).f n,
  dsimp only [sum_f, universal_map.sum],
  simp only [fin.default_eq_zero, finset.univ_unique, finset.sum_singleton],
  refine congr_arg of _,
  apply basic_universal_map.one_mul_hom_eq_proj,
end
| (N+1) :=
begin
  dsimp [pow'_iso_mul, hom_pow'],
  slice_lhs 2 3 { rw [← functor.map_comp, hom_pow'_sum] },
  rw iso.inv_comp_eq,
  ext i : 2,
  iterate 2 { erw [homological_complex.comp_f] },
  dsimp [mul_mul_iso, FreeMat.mul_mul_iso, universal_map.sum],
  rw [universal_map.mul_of],
  show universal_map.comp _ _ = universal_map.comp _ _,
  simp only [universal_map.comp_of, add_monoid_hom.map_sum, add_monoid_hom.finset_sum_apply],
  congr' 1,
  rw [← finset.sum_product', finset.univ_product_univ, ← fin_prod_fin_equiv.symm.sum_comp],
  apply fintype.sum_congr,
  apply basic_universal_map.comp_proj_mul_proj,
end
.

lemma hom_pow'_sum' (N : ℕ) : hom_pow' (BD.sum 2) N = (BD.pow'_iso_mul N).hom ≫ BD.sum (2^N) :=
by { rw ← iso.inv_comp_eq, apply hom_pow'_sum }

lemma hom_pow'_proj : ∀ N, (BD.pow'_iso_mul N).inv ≫ hom_pow' (BD.proj 2) N = BD.proj (2^N)
| 0     :=
begin
  ext n : 2,
  simp only [hom_pow', category.comp_id],
  show (BD.pow'_iso_mul 0).inv.f n = (BD.proj 1).f n,
  dsimp only [proj_f, universal_map.proj],
  refine congr_arg of _,
  apply basic_universal_map.one_mul_hom_eq_proj,
end
| (N+1) :=
begin
  dsimp [pow'_iso_mul, hom_pow'],
  slice_lhs 2 3 { rw [← functor.map_comp, hom_pow'_proj] },
  rw iso.inv_comp_eq,
  ext i : 2,
  iterate 2 { erw [homological_complex.comp_f] },
  dsimp [mul_mul_iso, FreeMat.mul_mul_iso, universal_map.proj],
  simp only [add_monoid_hom.map_sum, add_monoid_hom.finset_sum_apply,
    preadditive.comp_sum, preadditive.sum_comp],
  rw [← finset.sum_comm, ← finset.sum_product', finset.univ_product_univ,
      ← fin_prod_fin_equiv.symm.sum_comp],
  apply fintype.sum_congr,
  intros j,
  rw [universal_map.mul_of],
  show universal_map.comp _ _ = universal_map.comp _ _,
  simp only [universal_map.comp_of, basic_universal_map.comp_proj_mul_proj],
end

lemma hom_pow'_proj' (N : ℕ) : hom_pow' (BD.proj 2) N = (BD.pow'_iso_mul N).hom ≫ BD.proj (2^N) :=
by { rw ← iso.inv_comp_eq, apply hom_pow'_proj }

end data

end breen_deligne


import inner_product_spaces.real_ip.hilbert_space
import linear_algebra.basis
import tactic.interactive

noncomputable theory

variables {α : Type*}

open real set module submodule linear_map set

variables [decidable_eq α] [add_comm_group α] [vector_space ℝ α] [ℝ_inner_product_space α]

section norm_known

def α_normed_space : normed_space ℝ α := ip_space_is_normed_space

local attribute [instance] α_normed_space
local attribute [instance] classical.prop_decidable

def orthog_set (L : set α) : Prop :=
∀ (a b ∈ L), a ≠ b → a ⊥ b

lemma emptyset_orthog : orthog_set (∅ : set α) :=
by {dsimp [orthog_set], simp}

lemma add_elt_to_orthog (L : set α) (x : α) (h : orthog_set L) (w : ∀ (y ∈ L), x ⊥ y) : orthog_set (L ∪ {x}) :=
begin
    dsimp [orthog_set] at *,
    intros a b k₁ k₂ k₃,
    cases k₁,
    cases k₂,

    exact h a b k₁ k₂ k₃,

    apply orthog_symm,
    rw [eq_of_mem_singleton k₂],
    exact w a k₁,

    cases k₂,

    rw [eq_of_mem_singleton k₁],
    exact w b k₂,

    have k₃ := (eq_of_mem_singleton k₂).symm,
    rw [←eq_of_mem_singleton k₁] at k₃,
    contradiction,
end

lemma orthog_subset (L S : set α) (h : orthog_set L) (w : S ⊆ L) : orthog_set S :=
by {dsimp [orthog_set] at *,
    dsimp [(⊆), set.subset] at w,
    intros a b k₁ k₂ k₃,
    exact (h a b (w k₁) (w k₂) k₃)}

def orthonormal (L : set α) : Prop :=
orthog_set L ∧ ∀ (a ∈ L), ∥a∥=1

def normalise (L : set α) := image (λ (a : α), (1/∥a∥ : ℝ) • a) L

lemma elem_of_normalised (L : set α) (x : α) (h : x ∈ normalise L) : ∃ (y ∈ L) (a : ℝ), a • y = x :=
by {dsimp [normalise, image] at h, rcases h with ⟨y, hl, hr⟩,
    use y, use hl, use (1 / ∥y∥), exact hr}

lemma elem_of_normalised' (L : set α) (x : α) (h : x ∈ L) : ((1 / ∥x∥ : ℝ) • x) ∈ normalise L :=
by {dsimp [normalise, image], use x, exact ⟨h, rfl⟩}

lemma norm_one_of_norm_inv (x : α) (h : x ≠ 0) : ∥(1/∥x∥)•x∥ = 1 :=
by {rw [one_div_eq_inv, @norm_smul ℝ α _ ip_space_is_normed_space _ x, norm_inv,
    @norm_norm α ip_space_is_normed_group, inv_mul_cancel],
    exact (@norm_neq_zero_iff_neq_zero α ip_space_is_normed_space x).2 h}

lemma norm_one_of_normalised (L : set α) (h : (0 : α) ∉ L) (a : α) (w : a ∈ normalise L) : ∥a∥=1 :=
begin
    dsimp [normalise] at w,
    simp at w,
    rcases w with ⟨b, k₁, k₂⟩,
    have k₃ : b ≠ 0, begin
        by_contradiction,
        simp only [not_not] at a_1,
        rw [a_1] at k₁,
        contradiction,
    end,
    rw [←k₂, ←one_div_eq_inv],
    exact norm_one_of_norm_inv b k₃,
end

lemma zero_not_elem_of_normalised (L : set α) (h : (0 : α) ∉ L) : (0 : α) ∉ normalise L :=
by {by_contradiction, have w := norm_one_of_normalised L h 0 a, simp at w, exact w}

lemma orthog_normalised_of_orthog (L : set α) (h : orthog_set L) : orthog_set (normalise L) :=
begin
    dsimp [orthog_set] at *,
    dsimp [normalise],
    simp,
    intros a b x k₁ k₂ y k₃ k₄ k₅,
    have k₆ : x ≠ y, begin
        by_contradiction,
        simp only [not_not] at a_1,
        rw [a_1] at k₂,
        rw [k₂] at k₄,
        contradiction,
    end,
    rw [←k₄, ←k₂],
    exact mul_orthog x y (∥x∥)⁻¹ (∥y∥)⁻¹ (h x y k₁ k₃ k₆),
end

lemma orthonormal_normalised_of_orthog_set (L : set α) (h : orthog_set L) (w : (0 : α) ∉ L) : orthonormal (normalise L) :=
by {dsimp [orthonormal], exact ⟨orthog_normalised_of_orthog L h, norm_one_of_normalised L w⟩}

lemma orthog_set_is_lin_indep (L : set α) (h : orthog_set L) (w : (0 : α) ∉ L) : linear_independent ℝ L :=
begin
    rw [linear_independent_iff],
    intros l k₁ k₂,
    -- rw [linear_combination.mem_supported] at k₁,
    sorry,
end

lemma scale_elem_in_span (L : set α) (x : α) (a : ℝ) (h : x ∈ span ℝ L) : (a • x) ∈ span ℝ L :=
by {rw [mem_span] at *, intros p k, exact smul p a (h p k)}

lemma elem_span_of_elem_normalised (L : set α) (x : α) (a : x ∈ normalise L) : x ∈ span ℝ L :=
begin
    have w₁ := elem_of_normalised L x a,
    rcases w₁ with ⟨y, w₁, a, w₂⟩,
    have w₃ := @subset_span ℝ _ _ _ _ _,
    rw [←w₂],
    exact scale_elem_in_span L y a (w₃ w₁),
end

lemma normalised_subset_span (L : set α) : normalise L ⊆ ↑(span ℝ L) := elem_span_of_elem_normalised L

lemma in_submodule_of_normalised_in_submodule (L : set α) (p : submodule ℝ α) (k : normalise L ⊆ ↑p) : L ⊆ ↑p :=
begin
    have w : ∀ (x : α), x ∈ L → x ∈ ↑p := begin
        intros x l,
        by_cases (x = 0),

        rw [mem_coe p, h],
        exact zero_mem p,

        have w₁ := elem_of_normalised' L x l,
        have w₂ := k w₁,
        rw [mem_coe] at w₂,
        have w₃ := smul p (∥x∥) w₂,
        rw [smul_smul, one_div_eq_inv, mul_inv_cancel, one_smul] at w₃,
        rw [mem_coe],
        exact w₃,
        rw [←ne.def] at h,
        exact (norm_neq_zero_iff_neq_zero x).2 h,
    end,
    exact w,
end

lemma span_of_normalised_is_span (L : set α) : span ℝ (normalise L) = span ℝ L :=
begin
    ext,
    rw [mem_span],
    constructor,

    intros h,
    exact (h (span ℝ L)) (normalised_subset_span L),

    intros h p w,
    have h' := mem_span.1 h,
    have h₁ := h' p,
    exact h₁ (in_submodule_of_normalised_in_submodule L p w),
end

def orthonormal_basis (L : set α) := orthonormal L ∧ is_basis ℝ L

theorem normalised_basis_is_orthonormal_basis (L : set α) (h : is_basis ℝ L) (k : orthog_set L) : orthonormal_basis (normalise L) :=
begin
    dsimp [orthonormal_basis, is_basis] at *,
    cases h,
    have w := zero_not_mem_of_linear_independent (@zero_ne_one ℝ _) h_left,
    exact ⟨by {dsimp [orthonormal],
    exact ⟨orthog_normalised_of_orthog L k, norm_one_of_normalised L w⟩},
    by {exact ⟨orthog_set_is_lin_indep _ (orthog_normalised_of_orthog L k) (zero_not_elem_of_normalised L w),
    by {simpa [span_of_normalised_is_span]}⟩}⟩,
end

-- The Gram-Schimdt Procedure. Never finished defining it because I ended up
-- doing most of my work without fixing a basis.

-- def gram_partial (s : ℕ → α) : ℕ → set α
-- | 0 := {∥s 0∥⁻¹ • s 0}
-- | n := sorry

-- def gram_schmidt (s : ℕ → α) : ℕ → α :=
-- ⋃₀ {L | ∃ (n : ℕ), L = gram_partial s n}

end norm_known

section perp_space

def perp (L : set α) : set α := {x | ∀ (y ∈ L), x ⊥ y}

lemma perp_perp (L : set α) : L ⊆ perp (perp L) :=
begin
    have w : ∀ (x : α), x ∈ L → x ∈ perp (perp L) := begin
        intros x h,
        dsimp [perp],
        intros y k,
        have k₁ := orthog_symm (k x h),
        exact k₁,
    end,
    exact w,
end

lemma perp_antitone (S : set α) (L : set α) (h : S ⊆ L) : perp L ⊆ perp S :=
begin
    have w : ∀ (x : α), x ∈ perp L → x ∈ perp S := begin
        intros x w,
        dsimp [perp] at *,
        intros y k,
        exact w y (h k),
    end,
    exact w,
end

variables {S : set α}

lemma perp_add_closed (x y : α) (hx : x ∈ perp S) (hy : y ∈ perp S) : x + y ∈ perp S :=
begin
    dsimp [perp] at *,
    intros z hz,
    exact add_orthog (hx z hz) (hy z hz),
end

lemma perp_smul_closed (c : ℝ) (x : α) (hx : x ∈ perp S) : c•x ∈ perp S :=
begin
    dsimp [perp] at *,
    intros z hz,
    rw [←one_smul ℝ z],
    exact @mul_orthog α _ _ _ _ x z c 1 (hx z hz),
end

lemma zero_in_perp : (0 : α) ∈ perp S :=
begin
    dsimp [perp],
    intros y h,
    exact right_orthog_to_zero y,
end

def perp_subspace : subspace ℝ α :=
{carrier := perp S,
 zero := zero_in_perp,
 add := perp_add_closed,
 smul := perp_smul_closed}

lemma sub_simp {α : Type*} [add_comm_group α] [vector_space ℝ α] {S : subspace ℝ α} {y : α} : y ∈ S ↔ y ∈ S.carrier :=
by {rw [←submodule.mem_coe], unfold_coes}

lemma perp_singleton_ker (x : α) : perp {x} = (linear_map.ker (ip_map x)).carrier :=
begin
    ext y,
    rw [←sub_simp, mem_ker, ip_map_to_fun],
    dsimp [perp],
    split,

    intros h,
    have h₁ := h x (mem_singleton x),
    dsimp [orthog] at h₁,
    rw [conj_symm] at h₁,
    exact h₁,

    intros h z w,
    have k := eq_of_mem_singleton w,
    dsimp [orthog],
    rw [conj_symm, k],
    exact h,
end

lemma functional_ker_is_preimage_zero {f : α →ₗ[ℝ] ℝ} : (linear_map.ker f).carrier = f⁻¹' {0} :=
by {ext, rw [←sub_simp], simp}

lemma bounded_functional_ker_closed {f : α →ₗ[ℝ] ℝ} {w : @is_bounded_linear_map ℝ _ α ip_space_is_normed_space _ _ f} : @is_closed α α_topological_space (linear_map.ker f).carrier :=
by {rw [@functional_ker_is_preimage_zero α _ _ _ _],
    apply ((@continuous_iff_is_closed α ℝ α_topological_space ℝ_topological_space f).1 (@is_bounded_linear_map.continuous ℝ _ α ip_space_is_normed_space ℝ _ _ w) {0}),
    exact is_closed_singleton}

lemma ip_map_ker_is_preimage_zero (x : α) : (linear_map.ker (ip_map x)).carrier = (ip_map x)⁻¹' {0} :=
functional_ker_is_preimage_zero

lemma ip_map_ker_is_closed (x : α) : @is_closed α α_topological_space (linear_map.ker (ip_map x)).carrier :=
@bounded_functional_ker_closed α _ _ _ _ _ (ip_map_is_bounded_linear_map x)

lemma perp_singleton_closed (x : α) : @is_closed α α_topological_space (perp {x}) :=
by {rw [perp_singleton_ker], exact ip_map_ker_is_closed x}

lemma perp_int_singleton (S : set α) : perp S = ⋂₀ {L | ∃ (a ∈ S), L = perp ({a})} :=
begin
    ext x,
    rw [mem_sInter],
    split,

    intros h t w,
    simp at w,
    cases w with a w,
    cases w,
    dsimp [perp] at *,
    rw [w_right],
    simp,
    exact h a w_left,

    intros h y w,
    simp at h,
    have h₁ := h (perp {y}) y w rfl,
    dsimp [perp] at h₁,
    exact h₁ y (mem_singleton y),
end

lemma perp_int_trivial {l : (0 : α) ∈ S}: S ∩ perp S = {0} :=
begin
    ext,
    split,

    simp,
    intros h w,
    dsimp [perp] at w,
    have k := w x h,
    have k₁ := zero_of_norm_sq_zero x,
    dsimp [norm_sq] at k₁,
    dsimp [orthog] at k,
    exact k₁ k,

    intros h,
    have k := eq_of_mem_singleton h,
    rw [k],
    simp,
    split,
    exact l,
    exact zero_in_perp,
end

lemma perp_singleton_expr (S : set α) {t : set α} (h :t ∈ {L : set α | ∃ (a : α) (H : a ∈ S), L = perp {a}}) : ∃ (a ∈ S), t = perp {a} :=
by {rw [mem_set_of_eq] at h, exact h}

theorem perp_space_closed (S : set α) : @is_closed α α_topological_space (perp S) :=
begin
    rw [perp_int_singleton],
    apply @is_closed_sInter α α_topological_space _,
    intros t h,
    have k := perp_singleton_expr S h,
    rcases k with ⟨a, k₁, k₂⟩,
    rw [k₂],
    exact perp_singleton_closed a,
end

end perp_space

section orthogonal_projection

local attribute [instance] α_normed_space

variables [Hilbert_space α]
variables (S : submodule ℝ α)
variables (h : @is_closed α α_topological_space S.carrier)

include h

theorem proj_exists_unique (x : α) : ∃! (y : α), y ∈ S ∧ (∥x-y∥ = Inf {r | ∃ (z ∈ S), r = ∥x-z∥}) :=
begin
    sorry,
end

def orthog_proj (x : α) := classical.some (exists_of_exists_unique (proj_exists_unique S h x))

lemma orthog_classical (x : α) : orthog_proj S h x = classical.some (exists_of_exists_unique (proj_exists_unique S h x)) := rfl

lemma orthog_proj_mem (x : α) : orthog_proj S h x ∈ S :=
begin
    have w := classical.some_spec (exists_of_exists_unique (proj_exists_unique S h x)),
    rw [←orthog_classical] at w,
    cases w,
    exact w_left,
end

lemma orthog_proj_dist (x : α) : ∥x -  orthog_proj S h x∥ = Inf {r | ∃ (z ∈ S), r = ∥x-z∥} :=
begin
    have w := classical.some_spec (exists_of_exists_unique (proj_exists_unique S h x)),
    rw [←orthog_classical] at w,
    cases w,
    exact w_right,
end

lemma orthog_unique (x y z : α) (w : (y ∈ S ∧ (∥x-y∥ = Inf {r | ∃ (j ∈ S), r = ∥x-j∥})) ∧ (z ∈ S ∧ (∥x-z∥ = Inf {r | ∃ (j ∈ S), r = ∥x-j∥}))) : y = z :=
by {cases w, exact unique_of_exists_unique (proj_exists_unique S h x) w_left w_right}

lemma orthog_proj_suff (x y : α) (w : y ∈ S ∧ (∥x-y∥ = Inf {r | ∃ (z ∈ S), r = ∥x-z∥})) : y = orthog_proj S h x :=
by {apply orthog_unique S h, exact ⟨w, ⟨orthog_proj_mem S h x, orthog_proj_dist S h x⟩⟩}

lemma orthog_proj_suff' (x y : α) (w : y ∈ S ∧ (∥x-y∥ = Inf {r | ∃ (z ∈ S), r = ∥x-z∥})) : orthog_proj S h x = y :=
by {apply symm, exact orthog_proj_suff S h x y w}

lemma dist_bounded_below (x : α): ∃ (l : ℝ), ∀ (y : ℝ), y ∈ {r : ℝ | ∃ (z ∈ S), r = ∥x - z∥} → l ≤ y :=
begin
    use 0,
    intros y,
    simp,
    intros z w₁ w₂,
    rw [w₂],
    exact norm_nonneg _,
end

lemma dist_nonempty (x : α) : (∃ (r : ℝ), r ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥}) :=
begin
    use ∥x∥,
    simp,
    use 0,
    exact ⟨zero_mem S, by {simp}⟩,
end

lemma orthog_proj_id_on_S (x : α) (k : x ∈ S) : orthog_proj S h x = x :=
begin
    apply symm,
    apply orthog_proj_suff,
    split,

    exact k,
    simp,
    have w₁ : (0 : ℝ) ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥} := begin
        simp,
        use x,
        split,

        exact k,

        simp,
    end,
    have w₂ := @Inf_le {r | ∃ (z ∈ S), r = ∥x-z∥} (dist_bounded_below S h x) 0 w₁,
    have w₃ : (∀ (z : ℝ), z ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥} → 0 ≤ z) := begin
        intros z k₁,
        simp at k₁,
        cases k₁,
        cases k₁_h,
        rw [k₁_h_right],
        exact norm_nonneg _,
    end,
    have w₄ := (le_Inf {r | ∃ (z ∈ S), r = ∥x-z∥} (dist_nonempty S h _) (dist_bounded_below S h x)).2 w₃,
    have w₅ := (antisymm w₂ w₄).symm,
    simp at w₅,
    exact w₅,
end

lemma orthog_proj_zero_on_perp_S (x : α) (k : x ∈ perp S.carrier) : orthog_proj S h x = 0 :=
begin
    apply orthog_proj_suff',
    split,

    exact zero_mem S,
    rw [sub_zero],
    have w₁ : ∥x∥ ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥} := begin
        simp,
        use 0,
        split,

        exact zero_mem S,

        simp,
    end,
    have w₂ := Inf_le {r | ∃ (z ∈ S), r = ∥x-z∥} (dist_bounded_below S h x) w₁,
    have w₃ : (∃ (r : ℝ), r ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥}) := begin
        use ∥x∥,
        exact w₁,
    end,
    have w₄ : (∀ (z : ℝ), z ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥} → ∥x∥ ≤ z) := begin
        intros r l,
        simp at l,
        cases l with z l,
        cases l,
        rw ←norm_sqr_leq_iff_norm_leq,

        rw [l_right, pythagoras],
        simp,
        exact (norm_sq_nonneg z),

        dsimp [perp] at k,
        have k₁ := @mul_orthog α _ _ _ _ x z 1 (-1) (k z l_left),
        rw [one_smul, neg_one_smul] at k₁,
        exact k₁,
        rw [l_right],
        exact norm_nonneg _,
    end,
    have w₅ := (le_Inf {r | ∃ (z ∈ S), r = ∥x-z∥} w₃ (dist_bounded_below S h x)).2 w₄,
    exact (antisymm w₂ w₅).symm,
end

lemma orthog_proj_idempotent (x : α) : orthog_proj S h (orthog_proj S h x) = orthog_proj S h x :=
by {apply orthog_proj_id_on_S, exact orthog_proj_mem S h x}

lemma perp_mem_of_orthog_to_units (x : α) (k : ∀ (y ∈ S), ∥y∥=1 → x ⊥ y) : x ∈ perp S.carrier :=
begin
    dsimp [perp, orthog] at *,
    intros y k₁,
    by_cases (y=0),

    rw [h],
    exact left_orthog_to_zero x,

    revert h,
    intros k₂,
    rw [←ne.def] at k₂,
    have w₁ := k ((1/∥y∥) • y) (smul_mem S (1/∥y∥) k₁) (norm_one_of_norm_inv y k₂),
    have w₂ := mul_orthog x _ 1 (∥y∥) w₁,
    rw [one_smul, one_div_eq_inv, ←mul_smul, mul_inv_cancel ((norm_neq_zero_iff_neq_zero y).2 k₂), one_smul] at w₂,
    exact w₂,
end

lemma min_dist_expr (x y : α) (k : ∥y∥ = 1) : ∥x-(orthog_proj S h x + ⟪y ∥ x - orthog_proj S h x⟫•y)∥^2 = ∥x - orthog_proj S h x∥^2 - ⟪y ∥ x - orthog_proj S h x⟫^2 :=
begin
    rw [sub_eq_add_neg, ←neg_one_smul ℝ, smul_add, ←add_assoc, neg_one_smul ℝ, neg_one_smul ℝ,
    sqr_norm, sqr_norm, norm_sq_add (x + -orthog_proj S h x) (-(⟪y∥x - orthog_proj S h x⟫ • y))],
    dsimp [norm_sq],
    rw [←neg_one_smul ℝ (⟪y∥x + -orthog_proj S h x⟫ • y), smul_smul, mul_right, conj_symm y,
    mul_assoc, ←pow_two],
    ring,
    rw [add_assoc, sub_eq_add_neg (⟪x-orthog_proj S h x∥x-orthog_proj S h x⟫) (⟪x - orthog_proj S h x∥y⟫ ^ 2)],
    apply congr_arg (λ r, ⟪x - orthog_proj S h x∥x - orthog_proj S h x⟫ + r),
    rw [mul_left, mul_right],
    have w : norm_sq y = ⟪y ∥ y⟫ := rfl,
    rw [←w, ←sqr_norm, pow_two ∥y∥, k, mul_one, mul_one, ←pow_two, ←neg_one_mul ⟪x - orthog_proj S h x∥y⟫,
    mul_pow, neg_one_pow_eq_pow_mod_two],
    have w₁ : 2 % 2 = 0 := rfl,
    rw [w₁, pow_zero, ←neg_one_mul, ←mul_assoc, ←right_distrib],
    apply congr_arg (λ r, r * ⟪x - orthog_proj S h x∥y⟫ ^ 2),
    rw [←neg_neg (1 : ℝ), mul_comm, ←neg_one_mul, ←neg_one_mul (-(1 : ℝ)), mul_assoc, ←left_distrib],
    apply congr_arg (λ r, (-(1 : ℝ))*r),
    rw [neg_one_mul, neg_neg, one_mul, ←sub_eq_add_neg],
    have w₂ : (2 : ℝ) = 1 + 1 := rfl,
    rw [w₂, sub_eq_add_neg, add_assoc, add_right_neg, add_zero],
end

lemma orthog_of_orthog_proj_sub (x : α) : (x - orthog_proj S h x) ∈ perp S.carrier:=
begin
    apply perp_mem_of_orthog_to_units S h,
    intros y k₁ k₂,
    dsimp [orthog],
    have w₁ : ∥x-orthog_proj S h x∥ ≤ ∥x - (orthog_proj S h x + ⟪y ∥ x - orthog_proj S h x⟫ • y)∥ := begin
        have w₁ := orthog_proj_dist S h x,
        rw [w₁],
        have w₂ : ∥x - (orthog_proj S h x + ⟪y ∥ x - orthog_proj S h x⟫ • y)∥ ∈ {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥} := begin
            simp,
            existsi orthog_proj S h x + ⟪y ∥ x - orthog_proj S h x⟫ • y,
            split,
            exact add_mem S (orthog_proj_mem S h x) (smul_mem S _ k₁),
            simp,
        end,
        have w₃ := Inf_le {r : ℝ | ∃ (z : α) (H : z ∈ S), r = ∥x - z∥} (dist_bounded_below S h x) w₂,
        exact w₃,
    end,
    by_contradiction,
    rw [conj_symm, ←ne.def, ←sqr_pos_iff_neq_zero] at a,
    have w₃ : ∥x - orthog_proj S h x∥ ^ 2 - ⟪y ∥ x - orthog_proj S h x⟫ ^ 2 < ∥x-orthog_proj S h x∥^2 := begin
        rw [sub_eq_add_neg],
        conv {to_rhs, rw [←add_zero (∥x - orthog_proj S h x∥ ^ 2)]},
        apply (real.add_lt_add_iff_left (∥x - orthog_proj S h x∥ ^ 2)).2,
        exact neg_lt_zero.2 a,
    end,
    rw [←min_dist_expr S h x y k₂] at w₃,
    rw [←norm_sqr_leq_iff_norm_leq] at w₁,
    rw [lt_iff_not_ge] at w₃,
    exact absurd w₁ w₃,
    exact norm_nonneg _,
end

lemma orthog_proj_norm_leq (x : α) : ∥orthog_proj S h x∥ ≤ ∥x∥ :=
begin
    have k₁ := orthog_of_orthog_proj_sub S h x,
    dsimp [perp] at k₁,
    have w := pythagoras (k₁ (orthog_proj S h x) (orthog_proj_mem S h x)),
    rw [add_assoc, add_left_neg, add_zero, add_comm] at w,
    rw [←@norm_sqr_leq_iff_norm_leq _ _ _ _ (norm_nonneg _)],
    exact @leq_of_add_nonneg _ _ _ (sqr_nonneg _) (sqr_nonneg _) (sqr_nonneg _) w,
end

lemma orthog_proj_has_bound : ∃ M > 0, ∀ x : α, ∥orthog_proj S h x ∥ ≤ M * ∥ x ∥ :=
begin
    use 1,
    use zero_lt_one,
    intros x,
    rw [one_mul],
    exact orthog_proj_norm_leq S h x,
end

theorem orthog_direct_sum_exists (x : α) : ∃ (u ∈ S), ∃ (v ∈ perp S.carrier), x = u + v :=
begin
    use orthog_proj S h x,
    use orthog_proj_mem S h x,
    use (x-orthog_proj S h x),
    use orthog_of_orthog_proj_sub S h x,
    simp,
end

theorem orthog_direct_sum_unique (x u₁ u₂ v₁ v₂ : α) (U₁ : u₁ ∈ S) (U₂ : u₂ ∈ S) (V₁ : v₁ ∈ perp S.carrier) (V₂ : v₂ ∈ perp S.carrier)
(k₁ : x = u₁ + v₁) (k₂ : x = u₂ + v₂) : (u₁ = u₂ ∧ v₁ = v₂) :=
begin
    rw [k₁] at k₂,
    have k₃ : u₁ - u₂ = v₂ - v₁ := begin
        have l₁ := congr_arg (λ (z : α), z - u₂ - v₁) k₂,
        simp at l₁,
        rw [sub_eq_add_neg],
        exact l₁,
    end,
    have w₁ := sub_mem S U₁ U₂,
    have w₂ := @sub_mem ℝ α _ _ _ (@perp_subspace α _ _ _ _ S.carrier) v₂ v₁ V₂ V₁,
    have w₃ : u₁ - u₂ ∈ S.carrier ∩ perp S.carrier := begin
        split,
        exact w₁,
        rw [k₃],
        exact w₂,
    end,
    rw [@perp_int_trivial α _ _ _ _ S.carrier (zero_mem S)] at w₃,
    have w₄ := sub_eq_zero.1 (eq_of_mem_singleton w₃),
    rw [k₃] at w₃,
    exact ⟨w₄, (sub_eq_zero.1 (eq_of_mem_singleton w₃)).symm⟩,
end

theorem orthog_proj_of_orthog_direct_sum (x u v : α) (U : u ∈ S) (V : v ∈ perp S.carrier) (k : x = u + v) : orthog_proj S h x = u :=
begin
    have w₁ := orthog_direct_sum_unique S h x u (orthog_proj S h x) v (x - orthog_proj S h x) U (orthog_proj_mem S h x) V (orthog_of_orthog_proj_sub S h x) k (by simp),
    cases w₁,
    exact (w₁_left).symm,
end

lemma orthog_proj_add (x y : α) : orthog_proj S h (x+y) = orthog_proj S h x + orthog_proj S h y :=
begin
    have w₁ := orthog_direct_sum_exists S h x,
    rcases w₁ with ⟨ux, Ux, vx, Vx, w₁⟩,
    have w₂ := orthog_direct_sum_exists S h y,
    rcases w₂ with ⟨uy, Uy, vy, Vy, w₂⟩,
    have w₃ := orthog_proj_of_orthog_direct_sum S h x ux vx Ux Vx w₁,
    have w₄ := orthog_proj_of_orthog_direct_sum S h y uy vy Uy Vy w₂,
    rw [w₃, w₄],
    have w₅ : x + y = (ux + uy) + (vx + vy) := begin
        rw [w₁, w₂],
        simp,
    end,
    exact (orthog_proj_of_orthog_direct_sum S h (x+y) (ux+uy) (vx+vy) (add_mem S Ux Uy) (add_mem (perp_subspace) Vx Vy) w₅),
end

lemma orthog_proj_smul (c : ℝ) (x : α) : orthog_proj S h (c • x) = c • (orthog_proj S h x) :=
begin
    have w₁ := orthog_direct_sum_exists S h x,
    rcases w₁ with ⟨u, U, v, V, w₁⟩,
    have w₂ := orthog_proj_of_orthog_direct_sum S h x u v U V w₁,
    rw [w₂],
    have w₃ : c•x = c•u + c•v := begin
        rw [←smul_add, w₁],
    end,
    have w₅ := orthog_proj_of_orthog_direct_sum S h (c•x) (c•u) (c•v) (smul_mem S c U) (smul_mem (@perp_subspace α _ _ _ _ S.carrier) c V) w₃,
    rw [w₅],
end

def orthog_proj_linear : is_linear_map ℝ (orthog_proj S h) :=
{add := orthog_proj_add S h, smul := orthog_proj_smul S h}

lemma perp_of_orthog_proj_zero (x : α) (w : orthog_proj S h x = 0) : x ∈ perp S.carrier :=
begin
    have w₁ := orthog_direct_sum_exists S h x,
    rcases w₁ with ⟨u, U, v, V, w₁⟩,
    dsimp [perp, orthog] at *,
    intros y k,
    rw [w₁, add_left],
    have w₂ := orthog_proj_of_orthog_direct_sum S h x u v U V w₁,
    rw [w] at w₂,
    rw [←w₂, right_orthog_to_zero, zero_add],
    exact V y k,
end

theorem ker_orthog_img : (linear_map.ker (is_linear_map.mk' (orthog_proj S h) (orthog_proj_linear S h))).carrier = @perp α _ _ _ _ (linear_map.range ((is_linear_map.mk' (orthog_proj S h) (orthog_proj_linear S h)))).carrier :=
begin
    ext,
    rw [←sub_simp, mem_ker],
    split,

    intros k,
    dsimp [perp],
    intros y w,
    rw [←sub_simp] at w,
    simp at w,
    cases w with z w,
    simp at k,
    have w₁ := perp_of_orthog_proj_zero S h x k,
    have w₂ := orthog_proj_mem S h z,
    rw [w] at w₂,
    dsimp [perp] at w₁,
    exact w₁ y w₂,

    dsimp [perp],
    intros w,
    apply orthog_proj_zero_on_perp_S,
    dsimp [perp],
    intros y k,
    have w₁ := orthog_proj_id_on_S S h y k,
    have w₂ := w y,
    rw [←sub_simp] at w₂,
    simp at w₂,
    exact w₂ y w₁,
end

lemma orthog_proj_is_symmetric (x y : α) : ⟪orthog_proj S h x ∥ y⟫ = ⟪x ∥ orthog_proj S h y⟫ :=
begin
    have w₁ := orthog_direct_sum_exists S h x,
    rcases w₁ with ⟨u₁, U₁, v₁, V₁, w₁⟩,
    have w₂ := orthog_direct_sum_exists S h y,
    rcases w₂ with ⟨u₂, U₂, v₂, V₂, w₂⟩,
    rw [w₁, w₂],
    simp [orthog_proj_add],
    dsimp [perp] at *,
    have k₁ := V₂ (orthog_proj S h u₁) (orthog_proj_mem S h u₁),
    have k₂ := orthog_proj_zero_on_perp_S S h v₁ V₁,
    have k₃ := orthog_proj_zero_on_perp_S S h v₂ V₂,
    have k₄ := V₁ (orthog_proj S h u₂) (orthog_proj_mem S h u₂),
    dsimp [orthog] at *,
    rw [conj_symm] at k₁,
    rw [k₁, zero_add, k₂, right_orthog_to_zero, right_orthog_to_zero, add_zero, add_zero,
        k₃, left_orthog_to_zero, left_orthog_to_zero, add_zero, zero_add, k₄, add_zero,
        orthog_proj_id_on_S S h u₁ U₁, orthog_proj_id_on_S S h u₂ U₂],
end

lemma orthog_proj_is_bounded_linear_map : is_bounded_linear_map ℝ (orthog_proj S h) :=
begin
    constructor,

    constructor,
    exact orthog_proj_add S h,
    exact orthog_proj_smul S h,

    exact orthog_proj_has_bound S h,
end

end orthogonal_projection

section riesz_representation

local attribute [instance] classical.prop_decidable

variables (f : α →ₗ[ℝ] ℝ)

lemma fun_coe : ⇑f = f.to_fun := rfl

variables [Hilbert_space α]
variables (S : @submodule ℝ α _ _ _)

lemma perp_trivial_of_subspace_all (h : @is_closed α α_topological_space S.carrier) (k₁ : ∀ (x : α), x ∈ S) (y : α) (k₂ : y ∈ perp S.carrier) : y = 0 :=
by {dsimp [perp] at k₂, exact zero_of_orthog_self (k₂ y (k₁ y))}

lemma perp_nonempty_of_subspace_not_all (h : @is_closed α α_topological_space S.carrier) : (∃ (x : α), x ∉ S) → (∃ (y : α), y ≠ 0 ∧ y ∈ perp S.carrier) :=
begin
    rw [awesome_mt],
    simp,
    intros k,
    intros x,
    have k₁ := orthog_direct_sum_exists S h x,
    rcases k₁ with ⟨u, ⟨U, ⟨v, ⟨V, k₁⟩⟩⟩⟩,
    rw [k₁],
    have k₂ := k v,
    rw [awesome_mt] at k₂,
    simp at k₂,
    have k₃ := k₂ V,
    rw [k₃, add_zero],
    exact U,
end

lemma perp_nonempty_of_subspace_not_all' (h : @is_closed α α_topological_space S.carrier) (k : ∃ (x : α), x ∉ S) : ∃ (y : α), ∥y∥=1 ∧ y ∈ perp S.carrier :=
begin
    have k₁ := perp_nonempty_of_subspace_not_all S h k,
    rcases k₁ with ⟨z, k₁, k₂⟩,
    use ((1/∥z∥)•z),
    exact ⟨norm_one_of_norm_inv z k₁, smul_mem perp_subspace (1/∥z∥) k₂⟩,
end

theorem riesz_rep_exists (w : @is_bounded_linear_map ℝ _ α ip_space_is_normed_space _ _ f) : ∃ (x : α), f.to_fun = ip_map x :=
begin
    have w₁ := @bounded_functional_ker_closed α _ _ _ _ f w,
    have w₂ := orthog_direct_sum_exists (linear_map.ker f) w₁,
    by_cases k : (∀ (x : α), x ∈ linear_map.ker f),

    use 0,
    ext,
    simp,
    have w₃ := w₂ x,
    cases w₃ with u w₃,
    cases w₃ with w₃ w₄,
    cases w₄ with v w₄,
    cases w₄ with w₄ w₅,
    rw [w₅, linear_map.add],
    simp at w₃,
    rw [fun_coe] at w₃,
    simp [w₃],
    have w₆ := perp_trivial_of_subspace_all (linear_map.ker f) w₁ k v w₄,
    rw [w₆],
    exact linear_map.map_zero f,

    rw [not_forall] at k,
    have k₁ := perp_nonempty_of_subspace_not_all' (linear_map.ker f) w₁ k,
    rcases k₁ with ⟨z, ⟨k₁, k₂⟩⟩,
    use ((f z) • z),
    ext,
    have k₃ : (f x) • z - (f z) • x ∈ linear_map.ker f := begin
        simp,
        ring,
    end,
    dsimp [perp] at k₂,
    rw [←mul_one (f.to_fun x), ←mul_one ((f.to_fun x)*1), mul_assoc, ←pow_two, ←k₁, sqr_norm],
    dsimp [norm_sq],
    rw [←mul_left, ←add_zero (f.to_fun x • z), ←add_left_neg (f.to_fun z • x), ←add_assoc,
    add_left],
    have k₄ := k₂ _ k₃,
    dsimp [orthog] at k₄,
    rw [conj_symm, fun_coe] at k₄,
    rw [k₄, zero_add, fun_coe, mul_left, conj_symm, ←mul_left],
end

theorem riesz_rep_unique {x y : α} (h : f.to_fun = ip_map x) (w : f.to_fun = ip_map y) : x = y :=
begin
    apply left_ext x y,
    intros z,
    rw [h, fun_coe, fun_coe] at w,
    dsimp [ip_map] at w,
    have k₁ := @congr_arg _ _ z z (λ z, inner_product x z) rfl,
    conv at k₁ {to_rhs, rw [w]},
    exact k₁,
end

end riesz_representation

section adjoint

variables (f : α →ₗ[ℝ] α)
variables (h : @is_bounded_linear_map ℝ _ α ip_space_is_normed_space α ip_space_is_normed_space f)
variables [Hilbert_space α]

include f h

def adjoint_map (y : α): α →ₗ[ℝ] ℝ :=
begin
    refine_struct {..},
    use (λ x, ⟪f x ∥ y⟫),
    repeat {simp},
end

lemma adjoint_map_fun (y : α) : (adjoint_map f h y).to_fun = λ x, ⟪f.to_fun x ∥ y⟫ := rfl

lemma adjoint_map_bounded (y : α) : @is_bounded_linear_map ℝ _ α ip_space_is_normed_space _ _ (adjoint_map f h y) :=
begin
    constructor,

    constructor,
    repeat {simp},

    have h₁ := @is_bounded_linear_map.bound ℝ _ α ip_space_is_normed_space α ip_space_is_normed_space f h,
    by_cases (y=0),

    use 1,
    use zero_lt_one,
    intros x,
    have w₁ : (λ (x : α), ⟪f.to_fun x ∥ 0⟫) x = ⟪f.to_fun x ∥ 0⟫ := rfl,
    rw [fun_coe, adjoint_map_fun, h, w₁, left_orthog_to_zero, norm_zero, one_mul],
    apply norm_nonneg _,

    rcases h₁ with ⟨M, H, h₁⟩,
    use M*∥y∥,
    rw [←ne.def] at h,
    have w₁ := (@norm_pos_iff α ip_space_is_normed_group y).2 h,
    use mul_pos H w₁,
    intros x,
    apply le_trans (cauchy_schwarz (f x) y),
    rw [mul_assoc, mul_comm ∥y∥, ←mul_assoc],
    apply (mul_le_mul_right w₁).2,
    exact h₁ x,
end

def adjoint_to_fun : α → α :=
λ y, classical.some (riesz_rep_exists (adjoint_map f h y) (adjoint_map_bounded f h y))

lemma adjoint_ip_switch (x y : α) : ⟪f x ∥ y⟫ = ⟪x ∥ adjoint_to_fun f h y⟫ :=
begin
    have w := classical.some_spec (riesz_rep_exists (adjoint_map f h y) (adjoint_map_bounded f h y)),
    have k := adjoint_map_fun f h y,
    rw [w] at k,
    simp at k,
    dsimp [adjoint_to_fun],
    have k' := @congr_arg _ _ x x (λ (x : α), ⟪f.to_fun x ∥ y⟫) rfl,
    conv at k' {to_rhs, rw [←k, conj_symm]},
    exact k',
end

lemma adjoint_ip_switch' (x y : α) : ⟪adjoint_to_fun f h x ∥ y⟫ = ⟪x ∥ f y⟫ :=
by {rw [conj_symm, ←adjoint_ip_switch, conj_symm]}

lemma adjoint_to_fun_unique (S : α → α) (w : ∀ (x y : α), ⟪f x ∥ y⟫ = ⟪x ∥ S y⟫) : S = adjoint_to_fun f h :=
begin
    ext,
    apply @left_ext α _ _ _ _ _ _,
    intros z,
    have w' := w z x,
    have k := (adjoint_ip_switch f h) z x,
    rw [w', conj_symm, conj_symm z] at k,
    exact k,
end

lemma adjoint_to_fun_add (x y : α) : adjoint_to_fun f h (x+y) = adjoint_to_fun f h x + adjoint_to_fun f h y :=
begin
    apply @left_ext α _ _ _ _ _ _,
    intros z,
    rw [add_left, adjoint_ip_switch', adjoint_ip_switch', adjoint_ip_switch', add_left],
end

lemma adjoint_to_fun_smul (c : ℝ) (x : α) : adjoint_to_fun f h (c • x) = c • adjoint_to_fun f h x :=
begin
    apply @left_ext α _ _ _ _ _ _,
    intros z,
    rw [adjoint_ip_switch', mul_left, mul_left, adjoint_ip_switch'],
end

def adjoint : α →ₗ[ℝ] α :=
{to_fun := adjoint_to_fun f h, add := adjoint_to_fun_add f h, smul := adjoint_to_fun_smul f h}

local attribute [instance] α_normed_space

lemma adjoint_fun : (adjoint f h).to_fun = adjoint_to_fun f h := rfl

lemma adjoint_bounded : @is_bounded_linear_map ℝ _ α ip_space_is_normed_space α ip_space_is_normed_space (adjoint f h):=
begin
    constructor,
    constructor,
    exact adjoint_to_fun_add f h,
    exact adjoint_to_fun_smul f h,

    have w := h.bound,
    rcases w with ⟨M, H, w⟩,
    use M,
    use H,

    have k : ∀ (x y : α), ∥⟪adjoint_to_fun f h x ∥ y⟫∥≤M*∥x∥*∥y∥ := begin
        intros x y,
        rw [adjoint_ip_switch'],
        apply le_trans (cauchy_schwarz x _),
        have k := w y,
        by_cases (x=0),

        revert h,
        intros l,
        rw [l, norm_zero, zero_mul, mul_zero, zero_mul],

        revert h,
        intros l,
        rw [←ne.def] at l,
        rw [mul_comm, mul_assoc, mul_comm ∥x∥, ←mul_assoc],
        apply (mul_le_mul_right ((norm_pos_iff x).2 l)).2,
        exact k,
    end,
    intros x,
    by_cases (∥(adjoint f h).to_fun x∥ = 0),
    have k₁ : 0 ≤ M * ∥x∥ := mul_nonneg (le_of_lt H) (norm_nonneg x),
    rw [←h] at k₁,
    exact k₁,

    revert h,
    intros l,
    rw [←ne.def] at l,
    have k₁ := k x (adjoint_to_fun f h x),
    have k₂ := @sqr_norm α _ _ _ _ (adjoint_to_fun f h x),
    dsimp [norm_sq] at k₂,
    rw [←k₂, norm_sqr_eq_sqr, pow_two] at k₁,
    have k₄ := mul_le_mul_of_nonneg_right k₁ ((inv_nonneg.mpr (norm_nonneg (adjoint_to_fun f h x)))),
    rw [mul_assoc, mul_inv_cancel, mul_one, mul_assoc, mul_inv_cancel, mul_one] at k₄,
    exact k₄,
    rw [adjoint_fun] at l,
    repeat {exact l},
end

lemma adjoint_ext (S : α →ₗ[ℝ] α) (k : ∀ (x y : α), ⟪f x ∥ y⟫ = ⟪x ∥ S y⟫) : S = adjoint f h :=
begin
    ext,
    have k₁ := adjoint_to_fun_unique f h _ k,
    simp only [] at k₁,
    rw [k₁, ←adjoint_fun],
    refl,
end

lemma adjoint_is_involution : adjoint (adjoint f h) (adjoint_bounded f h) = f :=
begin
    apply eq.symm,
    apply adjoint_ext _ _,
    intros x y,
    exact adjoint_ip_switch' f h x y,
end

end adjoint


import data.int.interval
import algebra.big_operators.ring
import data.fintype.card
import category_theory.Fintype
import topology.order
import topology.separation
import topology.subset_properties
import data.real.nnreal

/-!

# \overline{\mathcal{M}}_r(S)_{\leq c}

Throughout, `S` is finite (not profinite).

`ℳ-bar_{r'}(S)_{≤c}` is the filtration on `ℳ-bar_{r'}(S)` by profinite subsets described
at the beginning of section 9 of `analytic.pdf`. It's defined not as a subset
of `ℳ-bar_{r'}(S)` but as an independent type. It's a projective limit of
types `Lbar_bdd r' S c M` which have an additional hypothesis that the power
series involved are actually polynomials of degree at most `M`.

## Main definitions

- `Lbar_bdd r' S c M`: the subset of `S → Tℤ[[T]]/(T^{M+1})` consisting of
  elements `F_s = ∑_{n=1}^M a_{n,s} T^n` such that `∑_{s,n} |a_{n,s}| (r')^n ≤ c`.
- `Lbar_bdd.limit r' S c`: the projective limit of `Lbar_bdd r' S c M`, as a subtype
  of the product.

-/
noncomputable theory
open_locale big_operators classical nnreal
open set

/-- `Lbar_bdd r' S c M` is the subset of `S → Tℤ[[T]]/(T^{M+1})` consisting of elements
`F_s = ∑_{n=1}^M a_{n,s} T^n` such that `∑_{s,n} |a_{n,s}| r^n ≤ c`.
This is an auxiliary object used to define the profinite topology on `Lbar r' S`. -/
structure Lbar_bdd (r : ℝ≥0) (S : Fintype) (c : ℝ≥0) (M : ℕ) :=
(to_fun      : S → fin (M + 1) → ℤ)
(coeff_zero' : ∀ s, to_fun s 0 = 0)
(sum_le'     : (∑ s i, (↑(to_fun s i).nat_abs * r^(i : ℕ))) ≤ c)

namespace Lbar_bdd

variables {r' : ℝ≥0} {S : Fintype} {c c₁ c₂ : ℝ≥0} {M : ℕ}

instance has_coe_to_fun : has_coe_to_fun (Lbar_bdd r' S c M) (λ _, S → fin (M + 1) → ℤ) :=
⟨Lbar_bdd.to_fun⟩

@[simp] lemma coe_mk (x h₁ h₂) : ((⟨x, h₁, h₂⟩ : Lbar_bdd r' S c M) : S → ℕ → ℤ) = x := rfl

@[simp] protected lemma coeff_zero (x : Lbar_bdd r' S c M) (s : S) : x s 0 = 0 := x.coeff_zero' s

protected lemma sum_le (x : Lbar_bdd r' S c M) :
  (∑ s i, ((↑(x s i).nat_abs * r'^(i:ℕ)))) ≤ c := x.sum_le'

/-- The obvious map from `Lbar_bdd r' S c₁ M` to `Lbar_bdd r' S c₂ M`, for `c₁ ≤ c₂`. -/
protected def cast_le [hc : fact (c₁ ≤ c₂)] (x : Lbar_bdd r' S c₁ M) : Lbar_bdd r' S c₂ M :=
⟨x.1, x.coeff_zero, x.sum_le.trans hc.out⟩

@[ext] lemma ext (x y : Lbar_bdd r' S c M) (h : (⇑x : S → fin (M + 1) → ℤ) = y) : x = y :=
by { cases x, cases y, congr, exact h }

instance : has_zero (Lbar_bdd r' S c M) :=
{ zero :=
  { to_fun := 0,
    coeff_zero' := λ s, rfl,
    sum_le' := by simp only [zero_mul, pi.zero_apply, finset.sum_const_zero,
      nat.cast_zero, zero_le', int.nat_abs_zero] } }

instance : inhabited (Lbar_bdd r' S c M) := ⟨0⟩

lemma coeff_bound [h0r : fact (0 < r')] (F : S → fin (M + 1) → ℤ)
  (hF : ∑ s i, (↑(F s i).nat_abs * r'^(i : ℕ)) ≤ c) (n : fin (M + 1)) (s : S) :
  ↑(F s n).nat_abs ≤ c / min (r' ^ M) 1 :=
begin
  rw [div_eq_mul_inv],
  apply le_mul_inv_of_mul_le ((lt_min (pow_pos h0r.out _) zero_lt_one).ne.symm),
  calc ↑(F s n).nat_abs * min (r' ^ M) 1 ≤ ↑(F s n).nat_abs * r' ^ (n:ℕ) : _ -- see below for proof
  ... ≤ ∑ i, (↑(F s i).nat_abs * r' ^ (i:ℕ)) :
    finset.single_le_sum (λ (i : fin (M + 1)) _, _) (finset.mem_univ n)
  ... ≤ ∑ s i, (↑(F s i).nat_abs * r'^(i:ℕ)) :
    by { refine finset.single_le_sum (λ _ _, _) (finset.mem_univ s),
      exact finset.sum_nonneg (λ _ _, (subtype.property (_ : ℝ≥0))) }
  ... ≤ c : hF,
  { refine mul_le_mul_of_nonneg_left _ (subtype.property (_ : ℝ≥0)),
    cases le_or_lt r' 1 with hr1 hr1,
    { refine le_trans (min_le_left _ _) _,
      exact pow_le_pow_of_le_one h0r.out.le hr1 (nat.lt_add_one_iff.1 n.2) },
    { exact le_trans (min_le_right _ _) (one_le_pow_of_one_le (le_of_lt hr1) _) } },
  apply subtype.property (_ : ℝ≥0)
end

/-- An auxiliary function used to prove finiteness of `Lbar_bdd r' S c M`. -/
private def temp_map [fact (0 < r')] (F : Lbar_bdd r' S c M) (n : fin (M + 1)) (s : S) :
  Icc (⌈(-(c / min (r' ^ M) 1) : ℝ)⌉) (⌊(c / min (r' ^ M) 1 : ℝ)⌋) :=
have h : (-(c / min (r' ^ M) 1) : ℝ) ≤ F s n ∧ (F s n : ℝ) ≤ (c / min (r' ^ M) 1 : ℝ),
by { rw [← abs_le, ← real.coe_nnabs, ← real.cast_nat_abs_eq_nnabs_cast],
    exact_mod_cast coeff_bound F F.sum_le n s },
⟨F s n, int.ceil_le.2 h.1, int.le_floor.2 h.2⟩

instance [fact (0 < r')] : fintype (Lbar_bdd r' S c M) :=
fintype.of_injective temp_map
begin
  rintros ⟨f1, hf1, hf1'⟩ ⟨f2, hf2, hf2'⟩ h,
  ext s n,
  change (temp_map ⟨f1, hf1, hf1'⟩ n s).1 = (temp_map ⟨f2, hf2, hf2'⟩ n s).1,
  rw h,
end

/-- The transition map from `Lbar_bdd r' S c N` to `Lbar_bdd r' S c M`, given `M ≤ N`. -/
def transition (r' : ℝ≥0) {S : Fintype} {c : ℝ≥0} {M N : ℕ} (h : M ≤ N) (x : Lbar_bdd r' S c N) :
  Lbar_bdd r' S c M :=
{ to_fun := λ s i, x s (fin.cast_le (add_le_add_right h 1) i),
  coeff_zero' := λ s, x.coeff_zero _,
  sum_le' :=
  begin
    refine le_trans _ x.sum_le,
    apply finset.sum_le_sum,
    intros s hs,
    let I := finset.map (fin.cast_le (add_le_add_right h 1)).to_embedding
      (finset.univ : finset (fin (M+1))),
    refine le_trans _
      (finset.sum_le_sum_of_subset_of_nonneg (finset.subset_univ I) _),
    { rw finset.sum_map,
      apply le_of_eq,
      congr },
    { intros, exact subtype.property (_ : ℝ≥0) }
  end }

lemma transition_eq {r' : ℝ≥0} {S : Fintype} {c : ℝ≥0} {M N : ℕ} (h : M ≤ N)
  (F : Lbar_bdd r' S c N) (s : S) (i : fin (M+1)) :
  (transition r' h F).1 s i = F.1 s (fin.cast_le (add_le_add_right h 1) i) := rfl

lemma transition_transition {r' : ℝ≥0} {S : Fintype} {c : ℝ≥0}
  {M N K : ℕ} (h : M ≤ N) (hh : N ≤ K) (x : Lbar_bdd r' S c K) :
  transition r' h (transition r' hh x) = transition r' (le_trans h hh) x := rfl

lemma transition_cast_le {N : ℕ} (h : M ≤ N) [hc : fact (c₁ ≤ c₂)] (x : Lbar_bdd r' S c₁ N) :
  transition r' h (Lbar_bdd.cast_le x : Lbar_bdd r' S c₂ N) =
    Lbar_bdd.cast_le (transition r' h x) := rfl

/-- The limit of `Lbar_bdd r' S c M` along the `transition` maps as `M` increases. -/
abbreviation limit (r' S c) :=
{ F : Π (M : ℕ), Lbar_bdd r' S c M // ∀ (M N : ℕ) (h : M ≤ N), transition r' h (F N) = F M }

/-- The obvious embedding `Lbar_bdd.limit r' S c`
into the product of `Lbar_bdd r' S c M` as `M` varies. -/
def emb_aux : limit r' S c → (Π (M : ℕ), Lbar_bdd r' S c M) := coe

section topological_structure

instance : topological_space (Lbar_bdd r' S c M) := ⊥
instance : discrete_topology (Lbar_bdd r' S c M) := ⟨rfl⟩

-- sanity check
example : t2_space (limit r' S c) := by apply_instance
example : totally_disconnected_space (limit r' S c) := by apply_instance
example [fact (0 < r')] : compact_space (Lbar_bdd r' S c M) := by apply_instance

lemma emb (r' S c) : closed_embedding (@emb_aux r' S c) :=
{ induced := rfl,
  inj := subtype.coe_injective,
  closed_range :=
  begin
    have : range emb_aux = ⋂ (x : {y : ℕ × ℕ // y.1 ≤ y.2}),
      {F : Π M, Lbar_bdd r' S c M | transition r' x.2 (F x.val.2) = F x.val.1},
    { ext,
      simp only [emb_aux, prod.forall, mem_Inter, mem_set_of_eq,
        subtype.range_coe_subtype, subtype.forall], },
    rw this,
    apply is_closed_Inter,
    rintros ⟨⟨m, n⟩, h0 : m ≤ n⟩,
    refine is_closed_eq (continuous.comp _ $ continuous_apply _) (continuous_apply _),
    exact continuous_of_discrete_topology,
  end }

instance [fact (0 < r')] : compact_space (limit r' S c) :=
begin
  erw [← is_compact_iff_compact_space, is_compact_iff_is_compact_univ,
    compact_iff_compact_in_subtype],
  apply is_closed.is_compact,
  exact (emb r' S c).is_closed_map _ is_closed_univ
end

/-- The projection from `Lbar_bdd.limit r' S c M` to `Lbar_bdd r' S c M`.  -/
def proj (M : ℕ) : Lbar_bdd.limit r' S c → Lbar_bdd r' S c M := λ F, F.1 M

lemma continuous_iff {α : Type*} [topological_space α] (f : α → Lbar_bdd.limit r' S c) :
  continuous f ↔ (∀ (M : ℕ), continuous ((proj M) ∘ f)) :=
begin
  split,
  { intros hf M,
    exact continuous.comp ((continuous_apply _).comp continuous_subtype_val) hf, },
  { intros h,
    rw [embedding.continuous_iff (emb r' S c).to_embedding],
    exact continuous_pi h }
end

end topological_structure

section addition

/-- The addition on `Lbar_bdd r' S c M`.
It takes a term of type `Lbar_bdd r' S c₁ M` and a term of type `Lbar_bdd r' S c₂ M`
and produces a term of type `Lbar_bdd r' S (c₁ + c₂) M`. -/
def add (F : Lbar_bdd r' S c₁ M) (G : Lbar_bdd r' S c₂ M) : Lbar_bdd r' S (c₁ + c₂) M :=
{ to_fun := F + G,
  coeff_zero' := λ s, by simp,
  sum_le' :=
  begin
    refine le_trans _ (add_le_add F.sum_le G.sum_le),
    rw ← finset.sum_add_distrib,
    refine finset.sum_le_sum _,
    rintro s -,
    rw ← finset.sum_add_distrib,
    refine finset.sum_le_sum _,
    rintro i -,
    rw ← add_mul,
    apply mul_le_mul_right',
    norm_cast,
    apply int.nat_abs_add_le
  end }

/-- Negation on `Lbar_bdd r' S c M` -/
def neg (F : Lbar_bdd r' S c M) : Lbar_bdd r' S c M :=
{ to_fun := -F,
  coeff_zero' := λ s, by simp,
  sum_le' := by { simp only [abs_neg, pi.neg_apply, int.nat_abs_neg], exact F.sum_le } }

end addition

section map

-- To avoid defeq nonsense, we need to use ⟨S⟩ as opposed to S.
-- TODO: Use `Fintype` everywhere?!
/-- TODO -/
def map {S T : Type*} [fintype S] [fintype T] (f : S → T) :
  Lbar_bdd r' ⟨S⟩ c M → Lbar_bdd r' ⟨T⟩ c M := λ F,
{ to_fun := λ t i, ∑ s in finset.univ.filter (λ s', f s' = t), F s i,
  coeff_zero' := by simp,
  sum_le' := calc
    ∑ (t : T) (i : fin (M+1)),
      ↑((∑ (s : S) in finset.univ.filter (λ s', f s' = t), F s i).nat_abs) * r' ^ (i : ℕ)
    ≤ ∑ (t : T) (i : fin (M+1)),
      ∑ s in finset.univ.filter (λ s', f s' = t), ↑(F s i).nat_abs * r' ^ (i : ℕ) :
    begin
      apply finset.sum_le_sum,
      rintros t -,
      apply finset.sum_le_sum,
      rintros i -,
      rw ← finset.sum_mul,
      refine mul_le_mul _ (le_refl _) zero_le' zero_le',
      rw ← nat.cast_sum,
      rw nat.cast_le,
      apply nat_abs_sum_le,
    end
    ... ≤ ∑ (s : S) (i : fin (M+1)), ↑(F s i).nat_abs * r' ^ (i : ℕ) :
    begin
      rw finset.sum_comm,
      nth_rewrite 1 finset.sum_comm,
      apply finset.sum_le_sum,
      rintro i -,
      rw ← finset.sum_bUnion,
      { apply finset.sum_le_sum_of_subset,
        intros _ _, simp },
      { rintros t1 - t2 - h s hs,
        simp at hs ⊢,
        apply h,
        rw [← hs.1, ← hs.2] }
    end
    ... ≤ _ : F.sum_le }

end map

end Lbar_bdd

#lint-


import breen_deligne.constants
import system_of_complexes.completion
import thm95.homotopy
import thm95.col_exact
import thm95.row_iso
import combinatorial_lemma.profinite

noncomputable theory

universes u v

open_locale nnreal -- enable the notation `ℝ≥0` for the nonnegative real numbers.

open polyhedral_lattice opposite
open thm95.universal_constants system_of_double_complexes category_theory breen_deligne
open ProFiltPseuNormGrpWithTinv (of)

section

variables (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' < 1)]
variables (BD : package)
variables (V : SemiNormedGroup.{v}) [normed_with_aut r V]
variables (κ κ' : ℕ → ℝ≥0) [BD.data.very_suitable r r' κ]
variables (M : ProFiltPseuNormGrpWithTinv.{u} r')
variables (m : ℕ)
variables (Λ : PolyhedralLattice.{u})

include BD κ κ' r r' M V

def thm95.IH (m : ℕ) : Prop := ∀ Λ : PolyhedralLattice.{u},
  ((BD.data.system κ r V r').obj (op $ Hom Λ M)).is_weak_bounded_exact
    (k κ' m) (K r r' BD κ' m) m (c₀ r r' BD κ κ' m Λ)

omit BD κ κ' r r' M V

lemma NSC_row_exact (IH : ∀ m' < m, thm95.IH r r' BD V κ κ' M m')
  (h0m : 0 < m) (i : ℕ) (hi : i ≤ m + 1) :
  ((thm95.double_complex BD.data κ r r' V Λ M (N r r' BD κ' m)).row i).is_weak_bounded_exact
    (k₁ κ' m) (K₁ r r' BD κ' m) (m - 1) (c₀ r r' BD κ κ' m Λ) :=
begin
  haveI h0m_ : fact (0 < m) := ⟨h0m⟩,
  have hm' : m - 1 < m := nat.pred_lt h0m.ne',
  rcases i with (i|i|i),
  { rw thm95.double_complex.row_zero,
    refine (IH (m-1) hm' Λ).of_le BD.data.system_admissible _ _ le_rfl _,
    swap 3,
    { apply c₀_mono, },
    all_goals { apply_instance } },
  { rw thm95.double_complex.row_one,
    refine (IH (m-1) hm' _).of_le BD.data.system_admissible _ _ le_rfl _,
    swap 3,
    { apply c₀_pred_le, exact h0m },
    all_goals { apply_instance } },
  { rw thm95.double_complex.row,
    apply system_of_complexes.rescale_is_weak_bounded_exact,
    refine (IH (m-1) hm' _).of_le BD.data.system_admissible _ _ le_rfl _,
    swap 3,
    { apply c₀_pred_le_of_le, exact hi },
    all_goals { apply_instance } }
end
.

variables [package.adept BD κ κ']

def NSC_htpy :
  normed_spectral_homotopy
    ((thm95.double_complex BD.data κ r r' V Λ M (N r r' BD κ' m)).row_map 0 1)
      m (k' κ' m) (ε r r' BD κ' m) (c₀ r r' BD κ κ' m Λ) (H r r' BD κ' m) :=
(NSH_aux BD r r' V κ κ' m Λ (op (Hom Λ M))).of_iso _ _ _
  (iso.refl _) (thm95.mul_rescale_iso_row_one BD.data κ r V _ _ (by norm_cast) Λ M)
  (λ _ _ _, rfl) (thm95.mul_rescale_iso_row_one_strict BD.data κ r V _ _ (by norm_cast) Λ M)
  (by apply thm95.row_map_eq_sum_comp)

def NSC (IH : ∀ m' < m, thm95.IH r r' BD V κ κ' M m')
  [pseudo_normed_group.splittable (Λ →+ M) (N r r' BD κ' m) (lem98.d Λ (N r r' BD κ' m))] :
  normed_spectral_conditions (thm95.double_complex BD.data κ r r' V Λ M (N r r' BD κ' m)) m
    (k₁ κ' m) (K₁ r r' BD κ' m) (k' κ' m) (ε r r' BD κ' m) (c₀ r r' BD κ κ' m Λ) (H r r' BD κ' m) :=
{ row_exact := NSC_row_exact _ _ _ _ _ _ _ _ _ IH,
  col_exact :=
  begin
    let N := N r r' BD κ' m,
    haveI : fact (r < 1) := ⟨(fact.out _ : r < r').trans (fact.out _ : r' < 1)⟩,
    intros j hj,
    refine thm95.col_exact BD.data κ r r' V Λ M N j (lem98.d Λ N) (k₁_sqrt κ' m) m _ _
      (k₁ κ' m) (K₁ r r' BD κ' m) (le_of_eq _) _ _ (c₀ r r' BD κ κ' m Λ) ⟨le_rfl⟩ infer_instance ⟨le_rfl⟩,
    { apply c₀_spec, assumption', },
    { ext, delta k₁_sqrt, dsimp, simp only [real.mul_self_sqrt, nnreal.zero_le_coe], },
    { apply K₁_spec }
  end,
  htpy := NSC_htpy r r' BD V κ κ' M m Λ,
  admissible := thm95.double_complex_admissible _ }

include BD κ κ' r r' m

/-- A variant of Theorem 9.5 in [Analytic] using weak bounded exactness. -/
theorem thm95' : ∀ (Λ : PolyhedralLattice.{u}) (S : Type u) [fintype S]
  (V : SemiNormedGroup.{v}) [normed_with_aut r V],
  ((BD.data.system κ r V r').obj (op $ Hom Λ (Lbar r' S))).is_weak_bounded_exact
    (k κ' m) (K r r' BD κ' m) m (c₀ r r' BD κ κ' m Λ) :=
begin
  apply nat.strong_induction_on m; clear m,
  introsI m IH Λ S _S_fin V _V_r,
  haveI : pseudo_normed_group.splittable
    (Λ →+ (of r' (Lbar r' S))) (N r r' BD κ' m) (lem98.d Λ (N r r' BD κ' m)) :=
    lem98_finite Λ S (N r r' BD κ' m),
  let cond := NSC.{u} r r' BD V κ κ' (of r' $ Lbar r' S) m Λ _,
  swap,
  { introsI m' hm' Λ,
    apply IH, assumption },
  exact normed_spectral cond
end

/-- A variant of Theorem 9.5 in [Analytic] using weak bounded exactness. -/
theorem thm95'.profinite : ∀ (Λ : PolyhedralLattice.{u}) (S : Profinite.{u})
  (V : SemiNormedGroup.{v}) [normed_with_aut r V],
  ((BD.data.system κ r V r').obj (op $ Hom Λ ((Lbar.functor.{u u} r').obj S))).is_weak_bounded_exact
    (k κ' m) (K r r' BD κ' m) m (c₀ r r' BD κ κ' m Λ) :=
begin
  apply nat.strong_induction_on m; clear m,
  introsI m IH Λ S V _V_r,
  haveI : pseudo_normed_group.splittable
    (Λ →+ (of r' ((Lbar.functor.{u u} r').obj S))) (N r r' BD κ' m) (lem98.d Λ (N r r' BD κ' m)) :=
    lem98.main r' Λ S (N r r' BD κ' m),
  let cond := NSC.{u} r r' BD V κ κ' (of r' $ (Lbar.functor.{u u} r').obj S) m Λ _,
  swap,
  { introsI m' hm' Λ,
    apply IH, assumption },
  exact normed_spectral cond
end

omit BD κ κ' r r' m

/-- Theorem 9.5 in [Analytic] -/
theorem thm95 (Λ : PolyhedralLattice.{u}) (S : Type u) [fintype S]
  (V : SemiNormedGroup.{v}) [normed_with_aut r V] :
  ((BD.data.system κ r V r').obj (op $ Hom Λ (Lbar r' S))).is_bounded_exact
    (k κ' m ^ 2) (K r r' BD κ' m + 1) m (c₀ r r' BD κ κ' m Λ) :=
begin
  refine system_of_complexes.is_weak_bounded_exact.strong_of_complete
    _ (thm95' r r' BD κ κ' m Λ S V) _ 1 zero_lt_one,
  apply data.system_admissible
end

/-- Theorem 9.5 in [Analytic] -/
theorem thm95.profinite (Λ : PolyhedralLattice.{u}) (S : Profinite.{u})
  (V : SemiNormedGroup.{v}) [normed_with_aut r V] :
  ((BD.data.system κ r V r').obj (op $ Hom Λ ((Lbar.functor.{u u} r').obj S))).is_bounded_exact
    (k κ' m ^ 2) (K r r' BD κ' m + 1) m (c₀ r r' BD κ κ' m Λ) :=
begin
  refine system_of_complexes.is_weak_bounded_exact.strong_of_complete
    _ (thm95'.profinite r r' BD κ κ' m Λ S V) _ 1 zero_lt_one,
  apply data.system_admissible
end

/-- Theorem 9.5 in [Analytic] -/
theorem thm94.explicit (S : Profinite.{0})
  (V : SemiNormedGroup.{v}) [normed_with_aut r V] :
  ((BD.data.system κ r V r').obj (op $ ⟨(Lbar.functor.{0 0} r').obj S⟩)).is_bounded_exact
    (k κ' m ^ 2) (K r r' BD κ' m + 1) m (c₀ r r' BD κ κ' m ⟨ℤ⟩) :=
begin
  refine (thm95.profinite r r' BD κ κ' m ⟨ℤ⟩ S V).of_iso
    ((BD.data.system κ r V r').map_iso (HomZ_iso ⟨(Lbar.functor.{0 0} r').obj S⟩).symm.op) _,
  intros c n,
  rw ← system_of_complexes.apply_hom_eq_hom_apply,
  apply SemiNormedGroup.iso_isometry_of_norm_noninc;
  apply breen_deligne.data.complex.map_norm_noninc
end

end

/- ===
Once we have determined the final shape of the statement,
we can update the proof `thm95' → first_target`, and then delete the theorem below.
Now I just want flexibility in changing `thm95`
and not be troubled with fixing the proof of the implication.
=== -/

/-- Theorem 9.5 in [Analytic] -/
theorem thm95'' (BD : package)
  (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' < 1)]
  (κ : ℕ → ℝ≥0) [BD.data.very_suitable r r' κ] [∀ (i : ℕ), fact (0 < κ i)] :
  ∀ m : ℕ,
  ∃ (k K : ℝ≥0) (hk : fact (1 ≤ k)),
  ∀ (Λ : Type u) [polyhedral_lattice Λ],
  ∃ c₀ : ℝ≥0,
  ∀ (S : Type u) [fintype S],
  ∀ (V : SemiNormedGroup.{v}) [normed_with_aut r V],
    by exactI system_of_complexes.is_weak_bounded_exact
    ((BD.data.system κ r V r').obj (op $ Hom Λ (Lbar r' S))) k K m c₀ :=
begin
  intro m,
  let κ' := package.κ' BD κ,
  haveI _inst_κ' : package.adept BD κ κ' := package.κ'_adept BD κ,
  refine ⟨(k κ' m), (K r r' BD κ' m), infer_instance, λ Λ _inst_Λ, _⟩,
  refine ⟨c₀ r r' BD κ κ' m (@PolyhedralLattice.of Λ _inst_Λ), λ S _inst_S V _inst_V, _⟩,
  apply thm95'
end

/-- Theorem 9.5 in [Analytic] -/
theorem thm95''.profinite (BD : package)
  (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' < 1)]
  (κ : ℕ → ℝ≥0) [BD.data.very_suitable r r' κ] [∀ (i : ℕ), fact (0 < κ i)] :
  ∀ m : ℕ,
  ∃ (k K : ℝ≥0) (hk : fact (1 ≤ k)),
  ∀ (Λ : Type u) [polyhedral_lattice Λ],
  ∃ c₀ : ℝ≥0,
  ∀ (S : Profinite.{u}),
  ∀ (V : SemiNormedGroup.{v}) [normed_with_aut r V],
    by exactI system_of_complexes.is_weak_bounded_exact
    ((BD.data.system κ r V r').obj (op $ Hom Λ ((Lbar.functor.{u u} r').obj S))) k K m c₀ :=
begin
  intro m,
  let κ' := package.κ' BD κ,
  haveI _inst_κ' : package.adept BD κ κ' := package.κ'_adept BD κ,
  refine ⟨(k κ' m), (K r r' BD κ' m), infer_instance, λ Λ _inst_Λ, _⟩,
  refine ⟨c₀ r r' BD κ κ' m (@PolyhedralLattice.of Λ _inst_Λ), λ S _inst_S V _inst_V, _⟩,
  apply thm95'.profinite
end