/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jeremy Avigad, Yury Kudryashov
-/
import order.filter.cofinite
import order.zorn

/-!
# Ultrafilters

An ultrafilter is a minimal (maximal in the set order) proper filter.
In this file we define

* `ultrafilter.of`: an ultrafilter that is less than or equal to a given filter;
* `ultrafilter`: subtype of ultrafilters;
* `ultrafilter.pure`: `pure x` as an `ultrafiler`;
* `ultrafilter.map`, `ultrafilter.bind`, `ultrafilter.comap` : operations on ultrafilters;
* `hyperfilter`: the ultrafilter extending the cofinite filter.
-/

universes u v
variables {α : Type u} {β : Type v}

open set filter function
open_locale classical filter

/-- An ultrafilter is a minimal (maximal in the set order) proper filter. -/
@[protect_proj]
structure ultrafilter (α : Type*) extends filter α :=
(ne_bot' : ne_bot to_filter)
(le_of_le : ∀ g, filter.ne_bot g → g ≤ to_filter → to_filter ≤ g)

namespace ultrafilter

variables {f g : ultrafilter α} {s t : set α} {p q : α → Prop}

instance : has_coe_t (ultrafilter α) (filter α) := ⟨ultrafilter.to_filter⟩

instance : has_mem (set α) (ultrafilter α) := ⟨λ s f, s ∈ (f : filter α)⟩

lemma unique (f : ultrafilter α) {g : filter α} (h : g ≤ f)
  (hne : ne_bot g . tactic.apply_instance) : g = f :=
le_antisymm h $ f.le_of_le g hne h

instance ne_bot (f : ultrafilter α) : ne_bot (f : filter α) := f.ne_bot'

@[simp, norm_cast] lemma mem_coe : s ∈ (f : filter α) ↔ s ∈ f := iff.rfl

lemma coe_injective : injective (coe : ultrafilter α → filter α)
| ⟨f, h₁, h₂⟩ ⟨g, h₃, h₄⟩ rfl := by congr

lemma eq_of_le {f g : ultrafilter α} (h : (f : filter α) ≤ g) : f = g :=
coe_injective (g.unique h)

@[simp, norm_cast] lemma coe_le_coe {f g : ultrafilter α} : (f : filter α) ≤ g ↔ f = g :=
⟨λ h, eq_of_le h, λ h, h ▸ le_rfl⟩

@[simp, norm_cast] lemma coe_inj : (f : filter α) = g ↔ f = g := coe_injective.eq_iff

@[ext] lemma ext ⦃f g : ultrafilter α⦄ (h : ∀ s, s ∈ f ↔ s ∈ g) : f = g :=
coe_injective $ filter.ext h

lemma le_of_inf_ne_bot (f : ultrafilter α) {g : filter α} (hg : ne_bot (↑f ⊓ g)) : ↑f ≤ g :=
le_of_inf_eq (f.unique inf_le_left hg)

lemma le_of_inf_ne_bot' (f : ultrafilter α) {g : filter α} (hg : ne_bot (g ⊓ f)) : ↑f ≤ g :=
f.le_of_inf_ne_bot $ by rwa inf_comm

@[simp] lemma compl_not_mem_iff : sᶜ ∉ f ↔ s ∈ f :=
⟨λ hsc, le_principal_iff.1 $ f.le_of_inf_ne_bot
  ⟨λ h, hsc $ mem_of_eq_bot$ by rwa compl_compl⟩, compl_not_mem⟩

@[simp] lemma frequently_iff_eventually : (∃ᶠ x in f, p x) ↔ ∀ᶠ x in f, p x :=
compl_not_mem_iff

alias frequently_iff_eventually ↔ filter.frequently.eventually _

lemma compl_mem_iff_not_mem : sᶜ ∈ f ↔ s ∉ f := by rw [← compl_not_mem_iff, compl_compl]

lemma diff_mem_iff (f : ultrafilter α) : s \ t ∈ f ↔ s ∈ f ∧ t ∉ f :=
inter_mem_iff.trans $ and_congr iff.rfl compl_mem_iff_not_mem

/-- If `sᶜ ∉ f ↔ s ∈ f`, then `f` is an ultrafilter. The other implication is given by
`ultrafilter.compl_not_mem_iff`.  -/
def of_compl_not_mem_iff (f : filter α) (h : ∀ s, sᶜ ∉ f ↔ s ∈ f) : ultrafilter α :=
{ to_filter := f,
  ne_bot' := ⟨λ hf, by simpa [hf] using h⟩,
  le_of_le := λ g hg hgf s hs, (h s).1 $ λ hsc, by exactI compl_not_mem hs (hgf hsc) }

lemma nonempty_of_mem (hs : s ∈ f) : s.nonempty := nonempty_of_mem hs
lemma ne_empty_of_mem (hs : s ∈ f) : s ≠ ∅ := (nonempty_of_mem hs).ne_empty
@[simp] lemma empty_not_mem : ∅ ∉ f := empty_not_mem f

lemma mem_or_compl_mem (f : ultrafilter α) (s : set α) : s ∈ f ∨ sᶜ ∈ f :=
or_iff_not_imp_left.2 compl_mem_iff_not_mem.2

protected lemma em (f : ultrafilter α) (p : α → Prop) :
  (∀ᶠ x in f, p x) ∨ ∀ᶠ x in f, ¬p x :=
f.mem_or_compl_mem {x | p x}

lemma eventually_or : (∀ᶠ x in f, p x ∨ q x) ↔ (∀ᶠ x in f, p x) ∨ ∀ᶠ x in f, q x :=
⟨λ H, (f.em p).imp_right $ λ hp, (H.and hp).mono $ λ x ⟨hx, hnx⟩, hx.resolve_left hnx,
  λ H, H.elim (λ hp, hp.mono $ λ x, or.inl) (λ hp, hp.mono $ λ x, or.inr)⟩

lemma union_mem_iff : s ∪ t ∈ f ↔ s ∈ f ∨ t ∈ f := eventually_or

lemma eventually_not : (∀ᶠ x in f, ¬p x) ↔ ¬∀ᶠ x in f, p x := compl_mem_iff_not_mem

lemma eventually_imp : (∀ᶠ x in f, p x → q x) ↔ (∀ᶠ x in f, p x) → ∀ᶠ x in f, q x :=
by simp only [imp_iff_not_or, eventually_or, eventually_not]

lemma finite_sUnion_mem_iff {s : set (set α)} (hs : finite s) : ⋃₀ s ∈ f ↔ ∃t∈s, t ∈ f :=
finite.induction_on hs (by simp) $ λ a s ha hs his,
  by simp [union_mem_iff, his, or_and_distrib_right, exists_or_distrib]

lemma finite_bUnion_mem_iff {is : set β} {s : β → set α} (his : finite is) :
  (⋃i∈is, s i) ∈ f ↔ ∃i∈is, s i ∈ f :=
by simp only [← sUnion_image, finite_sUnion_mem_iff (his.image s), bex_image_iff]

/-- Pushforward for ultrafilters. -/
def map (m : α → β) (f : ultrafilter α) : ultrafilter β :=
of_compl_not_mem_iff (map m f) $ λ s, @compl_not_mem_iff _ f (m ⁻¹' s)

@[simp, norm_cast] lemma coe_map (m : α → β) (f : ultrafilter α) :
  (map m f : filter β) = filter.map m ↑f := rfl

@[simp] lemma mem_map {m : α → β} {f : ultrafilter α} {s : set β} :
  s ∈ map m f ↔ m ⁻¹' s ∈ f := iff.rfl

/-- The pullback of an ultrafilter along an injection whose range is large with respect to the given
ultrafilter. -/
def comap {m : α → β} (u : ultrafilter β) (inj : injective m)
  (large : set.range m ∈ u) : ultrafilter α :=
{ to_filter := comap m u,
  ne_bot' := u.ne_bot'.comap_of_range_mem large,
  le_of_le := λ g hg hgu, by { resetI,
    simp only [← u.unique (map_le_iff_le_comap.2 hgu), comap_map inj, le_rfl] } }

@[simp] lemma mem_comap {m : α → β} (u : ultrafilter β) (inj : injective m)
  (large : set.range m ∈ u) {s : set α} :
  s ∈ u.comap inj large ↔ m '' s ∈ u :=
mem_comap_iff inj large

@[simp] lemma coe_comap {m : α → β} (u : ultrafilter β) (inj : injective m)
  (large : set.range m ∈ u) : (u.comap inj large : filter α) = filter.comap m u := rfl

/-- The principal ultrafilter associated to a point `x`. -/
instance : has_pure ultrafilter :=
⟨λ α a, of_compl_not_mem_iff (pure a) $ λ s, by simp⟩

@[simp] lemma mem_pure {a : α} {s : set α} : s ∈ (pure a : ultrafilter α) ↔ a ∈ s := iff.rfl

instance [inhabited α] : inhabited (ultrafilter α) := ⟨pure default⟩
instance [nonempty α] : nonempty (ultrafilter α) := nonempty.map pure infer_instance

lemma eq_principal_of_finite_mem {f : ultrafilter α} {s : set α} (h : s.finite) (h' : s ∈ f) :
  ∃ x ∈ s, (f : filter α) = pure x :=
begin
  rw ← bUnion_of_singleton s at h',
  rcases (ultrafilter.finite_bUnion_mem_iff h).mp h' with ⟨a, has, haf⟩,
  use [a, has],
  change (f : filter α) = (pure a : ultrafilter α),
  rw [ultrafilter.coe_inj, ← ultrafilter.coe_le_coe],
  change (f : filter α) ≤ pure a,
  rwa [← principal_singleton, le_principal_iff]
end

/-- Monadic bind for ultrafilters, coming from the one on filters
defined in terms of map and join.-/
def bind (f : ultrafilter α) (m : α → ultrafilter β) : ultrafilter β :=
of_compl_not_mem_iff (bind ↑f (λ x, ↑(m x))) $ λ s,
  by simp only [mem_bind', mem_coe, ← compl_mem_iff_not_mem, compl_set_of, compl_compl]

instance has_bind : has_bind ultrafilter := ⟨@ultrafilter.bind⟩
instance functor : functor ultrafilter := { map := @ultrafilter.map }
instance monad : monad ultrafilter := { map := @ultrafilter.map }

section

local attribute [instance] filter.monad filter.is_lawful_monad

instance is_lawful_monad : is_lawful_monad ultrafilter :=
{ id_map := assume α f, coe_injective (id_map f.1),
  pure_bind := assume α β a f, coe_injective (pure_bind a (coe ∘ f)),
  bind_assoc := assume α β γ f m₁ m₂, coe_injective (filter_eq rfl),
  bind_pure_comp_eq_map := assume α β f x, coe_injective (bind_pure_comp_eq_map f x.1) }

end

/-- The ultrafilter lemma: Any proper filter is contained in an ultrafilter. -/

alias exists_le ← filter.exists_ultrafilter_le

/-- Construct an ultrafilter extending a given filter.
  The ultrafilter lemma is the assertion that such a filter exists;
  we use the axiom of choice to pick one. -/
noncomputable def of (f : filter α) [ne_bot f] : ultrafilter α :=
classical.some (exists_le f)

lemma of_le (f : filter α) [ne_bot f] : ↑(of f) ≤ f := classical.some_spec (exists_le f)

lemma of_coe (f : ultrafilter α) : of ↑f = f :=
coe_inj.1 $ f.unique (of_le f)

lemma exists_ultrafilter_of_finite_inter_nonempty (S : set (set α))
  (cond : ∀ T : finset (set α), (↑T : set (set α)) ⊆ S → (⋂₀ (↑T : set (set α))).nonempty) :
  ∃ F : ultrafilter α, S ⊆ F.sets :=
begin
  suffices : ∃ F : filter α, ne_bot F ∧ S ⊆ F.sets,
  { rcases this with ⟨F, cond, hF⟩,
    resetI,
    obtain ⟨G : ultrafilter α, h1 : ↑G ≤ F⟩ := exists_le F,
    exact ⟨G, λ T hT, h1 (hF hT)⟩ },
  use filter.generate S,
  refine ⟨_, λ T hT, filter.generate_sets.basic hT⟩,
  rw ← forall_mem_nonempty_iff_ne_bot,
  intros T hT,
  rcases mem_generate_iff.mp hT with ⟨A, h1, h2, h3⟩,
  let B := set.finite.to_finset h2,
  rw (show A = ↑B, by simp) at *,
  rcases cond B h1 with ⟨x, hx⟩,
  exact ⟨x, h3 hx⟩,
end

end ultrafilter

namespace filter

open ultrafilter

lemma mem_iff_ultrafilter {s : set α} {f : filter α} :
  s ∈ f ↔ ∀ g : ultrafilter α, ↑g ≤ f → s ∈ g :=
begin
  refine ⟨λ hf g hg, hg hf, λ H, by_contra $ λ hf, _⟩,
  set g : filter ↥sᶜ := comap coe f,
  haveI : ne_bot g := comap_ne_bot_iff_compl_range.2 (by simpa [compl_set_of]),
  simpa using H ((of g).map coe) (map_le_iff_le_comap.mpr (of_le g))
end

lemma le_iff_ultrafilter {f₁ f₂ : filter α} : f₁ ≤ f₂ ↔ ∀ g : ultrafilter α, ↑g ≤ f₁ → ↑g ≤ f₂ :=
⟨λ h g h₁, h₁.trans h, λ h s hs, mem_iff_ultrafilter.2 $ λ g hg, h g hg hs⟩

/-- A filter equals the intersection of all the ultrafilters which contain it. -/
lemma supr_ultrafilter_le_eq (f : filter α) :
  (⨆ (g : ultrafilter α) (hg : ↑g ≤ f), (g : filter α)) = f :=
eq_of_forall_ge_iff $ λ f', by simp only [supr_le_iff, ← le_iff_ultrafilter]

/-- The `tendsto` relation can be checked on ultrafilters. -/
lemma tendsto_iff_ultrafilter (f : α → β) (l₁ : filter α) (l₂ : filter β) :
  tendsto f l₁ l₂ ↔ ∀ g : ultrafilter α, ↑g ≤ l₁ → tendsto f g l₂ :=
by simpa only [tendsto_iff_comap] using le_iff_ultrafilter

lemma exists_ultrafilter_iff {f : filter α} : (∃ (u : ultrafilter α), ↑u ≤ f) ↔ ne_bot f :=
⟨λ ⟨u, uf⟩, ne_bot_of_le uf, λ h, @exists_ultrafilter_le _ _ h⟩

lemma forall_ne_bot_le_iff {g : filter α} {p : filter α → Prop} (hp : monotone p) :
  (∀ f : filter α, ne_bot f → f ≤ g → p f) ↔ ∀ f : ultrafilter α, ↑f ≤ g → p f :=
begin
  refine ⟨λ H f hf, H f f.ne_bot hf, _⟩,
  introsI H f hf hfg,
  exact hp (of_le f) (H _ ((of_le f).trans hfg))
end

section hyperfilter

variables (α) [infinite α]

/-- The ultrafilter extending the cofinite filter. -/
noncomputable def hyperfilter : ultrafilter α := ultrafilter.of cofinite

variable {α}

lemma hyperfilter_le_cofinite : ↑(hyperfilter α) ≤ @cofinite α :=
ultrafilter.of_le cofinite

@[simp] lemma bot_ne_hyperfilter : (⊥ : filter α) ≠ hyperfilter α :=
(by apply_instance : ne_bot ↑(hyperfilter α)).1.symm

theorem nmem_hyperfilter_of_finite {s : set α} (hf : s.finite) : s ∉ hyperfilter α :=
λ hy, compl_not_mem hy $ hyperfilter_le_cofinite hf.compl_mem_cofinite

alias nmem_hyperfilter_of_finite ← set.finite.nmem_hyperfilter

theorem compl_mem_hyperfilter_of_finite {s : set α} (hf : set.finite s) :
  sᶜ ∈ hyperfilter α :=
compl_mem_iff_not_mem.2 hf.nmem_hyperfilter

alias compl_mem_hyperfilter_of_finite ← set.finite.compl_mem_hyperfilter

theorem mem_hyperfilter_of_finite_compl {s : set α} (hf : set.finite sᶜ) :
  s ∈ hyperfilter α :=
compl_compl s ▸ hf.compl_mem_hyperfilter

end hyperfilter

end filter

namespace ultrafilter

open filter

variables {m : α → β} {s : set α} {g : ultrafilter β}

lemma comap_inf_principal_ne_bot_of_image_mem (h : m '' s ∈ g) :
  (filter.comap m g ⊓ 𝓟 s).ne_bot :=
filter.comap_inf_principal_ne_bot_of_image_mem g.ne_bot h

/-- Ultrafilter extending the inf of a comapped ultrafilter and a principal ultrafilter. -/
noncomputable def of_comap_inf_principal (h : m '' s ∈ g) : ultrafilter α :=
@of _ (filter.comap m g ⊓ 𝓟 s) (comap_inf_principal_ne_bot_of_image_mem h)

lemma of_comap_inf_principal_mem (h : m '' s ∈ g) : s ∈ of_comap_inf_principal h :=
begin
  let f := filter.comap m g ⊓ 𝓟 s,
  haveI : f.ne_bot := comap_inf_principal_ne_bot_of_image_mem h,
  have : s ∈ f := mem_inf_of_right (mem_principal_self s),
  exact le_def.mp (of_le _) s this
end

lemma of_comap_inf_principal_eq_of_map (h : m '' s ∈ g) :
  (of_comap_inf_principal h).map m = g :=
begin
  let f := filter.comap m g ⊓ 𝓟 s,
  haveI : f.ne_bot := comap_inf_principal_ne_bot_of_image_mem h,
  apply eq_of_le,
  calc filter.map m (of f) ≤ filter.map m f : map_mono (of_le _)
  ... ≤ (filter.map m $ filter.comap m g) ⊓ filter.map m (𝓟 s) : map_inf_le
  ... = (filter.map m $ filter.comap m g) ⊓ (𝓟 $ m '' s) : by rw map_principal
  ... ≤ g ⊓ (𝓟 $ m '' s) : inf_le_inf_right _ map_comap_le
  ... = g : inf_of_le_left (le_principal_iff.mpr h)
end

end ultrafilter


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.algebra.tower
import linear_algebra.prod
import linear_algebra.finsupp
import algebra.algebra.operations

/-!
# Adjoining elements to form subalgebras

This file develops the basic theory of subalgebras of an R-algebra generated
by a set of elements. A basic interface for `adjoin` is set up.

## Tags

adjoin, algebra

-/

universes u v w

open_locale pointwise
open submodule subsemiring

variables {R : Type u} {A : Type v} {B : Type w}

namespace algebra

section semiring
variables [comm_semiring R] [semiring A] [semiring B]
variables [algebra R A] [algebra R B] {s t : set A}

theorem subset_adjoin : s ⊆ adjoin R s :=
algebra.gc.le_u_l s

theorem adjoin_le {S : subalgebra R A} (H : s ⊆ S) : adjoin R s ≤ S :=
algebra.gc.l_le H

lemma adjoin_eq_Inf : adjoin R s = Inf {p | s ⊆ p} :=
le_antisymm (le_Inf (λ _ h, adjoin_le h)) (Inf_le subset_adjoin)

theorem adjoin_le_iff {S : subalgebra R A} : adjoin R s ≤ S ↔ s ⊆ S:=
algebra.gc _ _

theorem adjoin_eq_of_le (S : subalgebra R A) (h₁ : s ⊆ S) (h₂ : S ≤ adjoin R s) : adjoin R s = S :=
le_antisymm (adjoin_le h₁) h₂

theorem adjoin_eq (S : subalgebra R A) : adjoin R ↑S = S :=
adjoin_eq_of_le _ (set.subset.refl _) subset_adjoin

lemma adjoin_Union {α : Type*} (s : α → set A) :
  adjoin R (set.Union s) = ⨆ (i : α), adjoin R (s i) :=
(@algebra.gc R A _ _ _).l_supr

lemma adjoin_attach_bUnion [decidable_eq A] {α : Type*} {s : finset α} (f : s → finset A) :
  adjoin R (s.attach.bUnion f : set A) = ⨆ x, adjoin R (f x) :=
by simpa [adjoin_Union]

@[elab_as_eliminator] theorem adjoin_induction {p : A → Prop} {x : A} (h : x ∈ adjoin R s)
  (Hs : ∀ x ∈ s, p x)
  (Halg : ∀ r, p (algebra_map R A r))
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
let S : subalgebra R A :=
{ carrier := p, mul_mem' := Hmul, add_mem' := Hadd, algebra_map_mem' := Halg } in
adjoin_le (show s ≤ S, from Hs) h

/-- Induction principle for the algebra generated by a set `s`: show that `p x y` holds for any
`x y ∈ adjoin R s` given that that it holds for `x y ∈ s` and that it satisfies a number of
natural properties. -/
@[elab_as_eliminator]
lemma adjoin_induction₂ {p : A → A → Prop} {a b : A} (ha : a ∈ adjoin R s) (hb : b ∈ adjoin R s)
  (Hs : ∀ (x ∈ s) (y ∈ s), p x y)
  (Halg : ∀ r₁ r₂, p (algebra_map R A r₁) (algebra_map R A r₂))
  (Halg_left : ∀ r (x ∈ s), p (algebra_map R A r) x)
  (Halg_right : ∀ r (x ∈ s), p x (algebra_map R A r))
  (Hadd_left : ∀ x₁ x₂ y, p x₁ y → p x₂ y → p (x₁ + x₂) y)
  (Hadd_right : ∀ x y₁ y₂, p x y₁ → p x y₂ → p x (y₁ + y₂))
  (Hmul_left : ∀ x₁ x₂ y, p x₁ y → p x₂ y → p (x₁ * x₂) y)
  (Hmul_right : ∀ x y₁ y₂, p x y₁ → p x y₂ → p x (y₁ * y₂))
  (Hadd_alg : ∀ x y r, p x (algebra_map R A r) →
                  p y (algebra_map R A r) → p (x + y) (algebra_map R A r))
  (Hmul_alg : ∀ x y r, p x (algebra_map R A r) →
                  p y (algebra_map R A r) → p (x * y) (algebra_map R A r)) : p a b :=
begin
  refine adjoin_induction hb _ (λ r, _) (Hadd_right a) (Hmul_right a),
  { exact adjoin_induction ha Hs Halg_left (λ x y Hx Hy z hz, Hadd_left x y z (Hx z hz) (Hy z hz))
      (λ x y Hx Hy z hz, Hmul_left x y z (Hx z hz) (Hy z hz)) },
  { exact adjoin_induction ha (Halg_right r) (λ r', Halg r' r) (λ x y, Hadd_alg x y r)
      (λ x y, Hmul_alg x y r) },
end

/-- The difference with `algebra.adjoin_induction` is that this acts on the subtype. -/
lemma adjoin_induction' {p : adjoin R s → Prop} (Hs : ∀ x (h : x ∈ s), p ⟨x, subset_adjoin h⟩)
  (Halg : ∀ r, p (algebra_map R _ r)) (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hmul : ∀ x y, p x → p y → p (x * y)) (x : adjoin R s) : p x :=
subtype.rec_on x $ λ x hx, begin
  refine exists.elim _ (λ (hx : x ∈ adjoin R s) (hc : p ⟨x, hx⟩), hc),
  exact adjoin_induction hx (λ x hx, ⟨subset_adjoin hx, Hs x hx⟩)
    (λ r, ⟨subalgebra.algebra_map_mem _ r, Halg r⟩)
    (λ x y hx hy, exists.elim hx $ λ hx' hx, exists.elim hy $ λ hy' hy,
    ⟨subalgebra.add_mem _ hx' hy', Hadd _ _ hx hy⟩) (λ x y hx hy, exists.elim hx $ λ hx' hx,
    exists.elim hy $ λ hy' hy, ⟨subalgebra.mul_mem _ hx' hy', Hmul _ _ hx hy⟩),
end

@[simp] lemma adjoin_adjoin_coe_preimage {s : set A} :
  adjoin R ((coe : adjoin R s → A) ⁻¹' s) = ⊤ :=
begin
  refine eq_top_iff.2 (λ x, adjoin_induction' (λ a ha, _) (λ r, _) (λ _ _, _) (λ _ _, _) x),
  { exact subset_adjoin ha },
  { exact subalgebra.algebra_map_mem _ r },
  { exact subalgebra.add_mem _ },
  { exact subalgebra.mul_mem _ }
end

lemma adjoin_union (s t : set A) : adjoin R (s ∪ t) = adjoin R s ⊔ adjoin R t :=
(algebra.gc : galois_connection _ (coe : subalgebra R A → set A)).l_sup

variables (R A)
@[simp] theorem adjoin_empty : adjoin R (∅ : set A) = ⊥ :=
show adjoin R ⊥ = ⊥, by { apply galois_connection.l_bot, exact algebra.gc }

@[simp] theorem adjoin_univ : adjoin R (set.univ : set A) = ⊤ :=
eq_top_iff.2 $ λ x, subset_adjoin $ set.mem_univ _

variables (R) {A} (s)

theorem adjoin_eq_span : (adjoin R s).to_submodule = span R (submonoid.closure s) :=
begin
  apply le_antisymm,
  { intros r hr, rcases subsemiring.mem_closure_iff_exists_list.1 hr with ⟨L, HL, rfl⟩, clear hr,
    induction L with hd tl ih, { exact zero_mem _ },
    rw list.forall_mem_cons at HL,
    rw [list.map_cons, list.sum_cons],
    refine submodule.add_mem _ _ (ih HL.2),
    replace HL := HL.1, clear ih tl,
    suffices : ∃ z r (hr : r ∈ submonoid.closure s), has_scalar.smul z r = list.prod hd,
    { rcases this with ⟨z, r, hr, hzr⟩, rw ← hzr,
      exact smul_mem _ _ (subset_span hr) },
    induction hd with hd tl ih, { exact ⟨1, 1, (submonoid.closure s).one_mem', one_smul _ _⟩ },
    rw list.forall_mem_cons at HL,
    rcases (ih HL.2) with ⟨z, r, hr, hzr⟩, rw [list.prod_cons, ← hzr],
    rcases HL.1 with ⟨hd, rfl⟩ | hs,
    { refine ⟨hd * z, r, hr, _⟩,
      rw [algebra.smul_def, algebra.smul_def, (algebra_map _ _).map_mul, _root_.mul_assoc] },
    { exact ⟨z, hd * r, submonoid.mul_mem _ (submonoid.subset_closure hs) hr,
        (mul_smul_comm _ _ _).symm⟩ } },
  refine span_le.2 _,
  change submonoid.closure s ≤ (adjoin R s).to_subsemiring.to_submonoid,
  exact submonoid.closure_le.2 subset_adjoin
end

lemma span_le_adjoin (s : set A) : span R s ≤ (adjoin R s).to_submodule :=
span_le.mpr subset_adjoin

lemma adjoin_to_submodule_le {s : set A} {t : submodule R A} :
  (adjoin R s).to_submodule ≤ t ↔ ↑(submonoid.closure s) ⊆ (t : set A) :=
by rw [adjoin_eq_span, span_le]

lemma adjoin_eq_span_of_subset {s : set A} (hs : ↑(submonoid.closure s) ⊆ (span R s : set A)) :
  (adjoin R s).to_submodule = span R s :=
le_antisymm ((adjoin_to_submodule_le R).mpr hs) (span_le_adjoin R s)

lemma adjoin_image (f : A →ₐ[R] B) (s : set A) :
  adjoin R (f '' s) = (adjoin R s).map f :=
le_antisymm (adjoin_le $ set.image_subset _ subset_adjoin) $
subalgebra.map_le.2 $ adjoin_le $ set.image_subset_iff.1 subset_adjoin

@[simp] lemma adjoin_insert_adjoin (x : A) :
  adjoin R (insert x ↑(adjoin R s)) = adjoin R (insert x s) :=
le_antisymm
  (adjoin_le (set.insert_subset.mpr
    ⟨subset_adjoin (set.mem_insert _ _), adjoin_mono (set.subset_insert _ _)⟩))
  (algebra.adjoin_mono (set.insert_subset_insert algebra.subset_adjoin))

lemma adjoin_prod_le (s : set A) (t : set B) :
  adjoin R (s ×ˢ t) ≤ (adjoin R s).prod (adjoin R t) :=
adjoin_le $ set.prod_mono subset_adjoin subset_adjoin

lemma mem_adjoin_of_map_mul {s} {x : A} {f : A →ₗ[R] B} (hf : ∀ a₁ a₂, f(a₁ * a₂) = f a₁ * f a₂)
  (h : x ∈ adjoin R s) : f x ∈ adjoin R (f '' (s ∪ {1})) :=
begin
  refine @adjoin_induction R A _ _ _ _ (λ a, f a ∈ adjoin R (f '' (s ∪ {1}))) x h
    (λ a ha, subset_adjoin ⟨a, ⟨set.subset_union_left _ _ ha, rfl⟩⟩)
    (λ r, _)
    (λ y z hy hz, by simpa [hy, hz] using subalgebra.add_mem _ hy hz)
    (λ y z hy hz, by simpa [hy, hz, hf y z] using subalgebra.mul_mem _ hy hz),
  have : f 1 ∈ adjoin R (f '' (s ∪ {1})) :=
  subset_adjoin ⟨1, ⟨set.subset_union_right _ _ $ set.mem_singleton 1, rfl⟩⟩,
  replace this := subalgebra.smul_mem (adjoin R (f '' (s ∪ {1}))) this r,
  convert this,
  rw algebra_map_eq_smul_one,
  exact f.map_smul _ _
end

lemma adjoin_inl_union_inr_eq_prod (s) (t) :
  adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})) =
    (adjoin R s).prod (adjoin R t) :=
begin
  apply le_antisymm,
  { simp only [adjoin_le_iff, set.insert_subset, subalgebra.zero_mem, subalgebra.one_mem,
      subset_adjoin, -- the rest comes from `squeeze_simp`
      set.union_subset_iff, linear_map.coe_inl, set.mk_preimage_prod_right,
      set.image_subset_iff, set_like.mem_coe, set.mk_preimage_prod_left, linear_map.coe_inr,
      and_self, set.union_singleton, subalgebra.coe_prod] },
  { rintro ⟨a, b⟩ ⟨ha, hb⟩,
    let P := adjoin R (linear_map.inl R A B '' (s ∪ {1}) ∪ linear_map.inr R A B '' (t ∪ {1})),
    have Ha : (a, (0 : B)) ∈ adjoin R ((linear_map.inl R A B) '' (s ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inl_map_mul) ha,
    have Hb : ((0 : A), b) ∈ adjoin R ((linear_map.inr R A B) '' (t ∪ {1})) :=
      mem_adjoin_of_map_mul R (linear_map.inr_map_mul) hb,
    replace Ha : (a, (0 : B)) ∈ P := adjoin_mono (set.subset_union_left _ _) Ha,
    replace Hb : ((0 : A), b) ∈ P := adjoin_mono (set.subset_union_right _ _) Hb,
    simpa using subalgebra.add_mem _ Ha Hb }
end

/-- If all elements of `s : set A` commute pairwise, then `adjoin R s` is a commutative
semiring.  -/
def adjoin_comm_semiring_of_comm {s : set A} (hcomm : ∀ (a ∈ s) (b ∈ s), a * b = b * a) :
  comm_semiring (adjoin R s) :=
{ mul_comm := λ x y,
  begin
    ext,
    simp only [subalgebra.coe_mul],
    exact adjoin_induction₂ x.prop y.prop
      hcomm
      (λ _ _, by rw [commutes])
      (λ r x hx, commutes r x) (λ r x hx, (commutes r x).symm)
      (λ _ _ _ h₁ h₂, by simp only [add_mul, mul_add, h₁, h₂])
      (λ _ _ _ h₁ h₂, by simp only [add_mul, mul_add, h₁, h₂])
      (λ x₁ x₂ y₁ h₁ h₂, by rw [mul_assoc, h₂, ←mul_assoc y₁, ←h₁, mul_assoc x₁])
      (λ x₁ x₂ y₁ h₁ h₂, by rw [mul_assoc x₂, ←h₂, ←mul_assoc x₂, ←h₁, ←mul_assoc])
      (λ _ _ _ _ _, by simp only [add_mul, mul_add, commutes])
      (λ _ _ _ _ _, by rw [commutes])
  end,
  ..(adjoin R s).to_semiring }

end semiring

section comm_semiring
variables [comm_semiring R] [comm_semiring A]
variables [algebra R A] {s t : set A}

variables (R s t)
theorem adjoin_union_eq_adjoin_adjoin :
  adjoin R (s ∪ t) = (adjoin (adjoin R s) t).restrict_scalars R :=
le_antisymm
  (closure_mono $ set.union_subset
    (set.range_subset_iff.2 $ λ r, or.inl ⟨algebra_map R (adjoin R s) r, rfl⟩)
    (set.union_subset_union_left _ $ λ x hxs, ⟨⟨_, subset_adjoin hxs⟩, rfl⟩))
  (closure_le.2 $ set.union_subset
    (set.range_subset_iff.2 $ λ x, adjoin_mono (set.subset_union_left _ _) x.2)
    (set.subset.trans (set.subset_union_right _ _) subset_adjoin))

lemma adjoin_singleton_one : adjoin R ({1} : set A) = ⊥ :=
eq_bot_iff.2 $ adjoin_le $ set.singleton_subset_iff.2 $ set_like.mem_coe.2 $ one_mem _

theorem adjoin_union_coe_submodule : (adjoin R (s ∪ t)).to_submodule =
  (adjoin R s).to_submodule * (adjoin R t).to_submodule :=
begin
  rw [adjoin_eq_span, adjoin_eq_span, adjoin_eq_span, span_mul_span],
  congr' 1 with z, simp [submonoid.closure_union, submonoid.mem_sup, set.mem_mul]
end

lemma pow_smul_mem_adjoin_smul (r : R) (s : set A) {x : A} (hx : x ∈ adjoin R s) :
  ∃ n₀ : ℕ, ∀ n ≥ n₀, r ^ n • x ∈ adjoin R (r • s) :=
begin
  change x ∈ (adjoin R s).to_submodule at hx,
  rw [adjoin_eq_span, finsupp.mem_span_iff_total] at hx,
  rcases hx with ⟨l, rfl : l.sum (λ (i : submonoid.closure s) (c : R), c • ↑i) = x⟩,
  choose n₁ n₂ using (λ x : submonoid.closure s, submonoid.pow_smul_mem_closure_smul r s x.prop),
  use l.support.sup n₁,
  intros n hn,
  rw finsupp.smul_sum,
  refine (adjoin R (r • s)).to_submodule.sum_mem _,
  intros a ha,
  have : n ≥ n₁ a := le_trans (finset.le_sup ha) hn,
  dsimp only,
  rw [← tsub_add_cancel_of_le this, pow_add, ← smul_smul, smul_smul _ (l a), mul_comm,
    ← smul_smul, adjoin_eq_span],
  refine submodule.smul_mem _ _ _,
  exact submodule.smul_mem _ _ (submodule.subset_span (n₂ a))
end

end comm_semiring

section ring
variables [comm_ring R] [ring A]
variables [algebra R A] {s t : set A}
variables {R s t}

theorem adjoin_int (s : set R) : adjoin ℤ s = subalgebra_of_subring (subring.closure s) :=
le_antisymm (adjoin_le subring.subset_closure)
  (subring.closure_le.2 subset_adjoin : subring.closure s ≤ (adjoin ℤ s).to_subring)

theorem mem_adjoin_iff {s : set A} {x : A} :
  x ∈ adjoin R s ↔ x ∈ subring.closure (set.range (algebra_map R A) ∪ s) :=
⟨λ hx, subsemiring.closure_induction hx subring.subset_closure (subring.zero_mem _)
  (subring.one_mem _) (λ _ _, subring.add_mem _) ( λ _ _, subring.mul_mem _),
  suffices subring.closure (set.range ⇑(algebra_map R A) ∪ s) ≤ (adjoin R s).to_subring,
    from @this x, subring.closure_le.2 subsemiring.subset_closure⟩

theorem adjoin_eq_ring_closure (s : set A) :
  (adjoin R s).to_subring = subring.closure (set.range (algebra_map R A) ∪ s) :=
subring.ext $ λ x, mem_adjoin_iff

variables (R)

/-- If all elements of `s : set A` commute pairwise, then `adjoin R s` is a commutative
ring.  -/
def adjoin_comm_ring_of_comm {s : set A} (hcomm : ∀ (a ∈ s) (b ∈ s), a * b = b * a) :
  comm_ring (adjoin R s) :=
{ ..(adjoin R s).to_ring,
  ..adjoin_comm_semiring_of_comm R hcomm }

end ring

end algebra

open algebra subalgebra

namespace alg_hom

variables [comm_semiring R] [semiring A] [semiring B] [algebra R A] [algebra R B]

lemma map_adjoin (φ : A →ₐ[R] B) (s : set A) :
  (adjoin R s).map φ = adjoin R (φ '' s) :=
(adjoin_image _ _ _).symm

lemma adjoin_le_equalizer (φ₁ φ₂ : A →ₐ[R] B) {s : set A} (h : s.eq_on φ₁ φ₂) :
  adjoin R s ≤ φ₁.equalizer φ₂ :=
adjoin_le h

lemma ext_of_adjoin_eq_top {s : set A} (h : adjoin R s = ⊤) ⦃φ₁ φ₂ : A →ₐ[R] B⦄
  (hs : s.eq_on φ₁ φ₂) : φ₁ = φ₂ :=
ext $ λ x, adjoin_le_equalizer φ₁ φ₂ hs $ h.symm ▸ trivial

end alg_hom


theorem subtype_inj (A: Type) (p: A → Prop) (a b: A) (pa: p a) (pb: p b) : (⟨a, pa⟩: {a//p a}) = (⟨b, pb⟩: {b//p b}) → a = b := by
  intro eq
  injection eq
  assumption


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Scott Morrison
-/
import algebra.homology.complex_shape
import category_theory.subobject.limits
import category_theory.graded_object

/-!
# Homological complexes.

A `homological_complex V c` with a "shape" controlled by `c : complex_shape ι`
has chain groups `X i` (objects in `V`) indexed by `i : ι`,
and a differential `d i j` whenever `c.rel i j`.

We in fact ask for differentials `d i j` for all `i j : ι`,
but have a field `shape'` requiring that these are zero when not allowed by `c`.
This avoids a lot of dependent type theory hell!

The composite of any two differentials `d i j ≫ d j k` must be zero.

We provide `chain_complex V α` for
`α`-indexed chain complexes in which `d i j ≠ 0` only if `j + 1 = i`,
and similarly `cochain_complex V α`, with `i = j + 1`.

There is a category structure, where morphisms are chain maps.

For `C : homological_complex V c`, we define `C.X_next i`, which is either `C.X j` for some
arbitrarily chosen `j` such that `c.r i j`, or the zero object if there is no such `j`.
Similarly we have `C.X_prev j`.
Defined in terms of these we have `C.d_from i : C.X i ⟶ C.X_next i` and
`C.d_to j : C.X_prev j ⟶ C.X j`, which are either defined as `C.d i j`, or zero, as needed.
-/

universes v u

open category_theory category_theory.category category_theory.limits

variables {ι : Type*}
variables (V : Type u) [category.{v} V] [has_zero_morphisms V]

/--
A `homological_complex V c` with a "shape" controlled by `c : complex_shape ι`
has chain groups `X i` (objects in `V`) indexed by `i : ι`,
and a differential `d i j` whenever `c.rel i j`.

We in fact ask for differentials `d i j` for all `i j : ι`,
but have a field `shape'` requiring that these are zero when not allowed by `c`.
This avoids a lot of dependent type theory hell!

The composite of any two differentials `d i j ≫ d j k` must be zero.
-/
structure homological_complex (c : complex_shape ι) :=
(X : ι → V)
(d : Π i j, X i ⟶ X j)
(shape' : ∀ i j, ¬ c.rel i j → d i j = 0 . obviously)
(d_comp_d' : ∀ i j k, c.rel i j → c.rel j k → d i j ≫ d j k = 0 . obviously)

namespace homological_complex

restate_axiom shape'
attribute [simp] shape

variables {V} {c : complex_shape ι}

@[simp, reassoc] lemma d_comp_d (C : homological_complex V c) (i j k : ι) :
  C.d i j ≫ C.d j k = 0 :=
begin
  by_cases hij : c.rel i j,
  { by_cases hjk : c.rel j k,
    { exact C.d_comp_d' i j k hij hjk },
    { rw [C.shape j k hjk, comp_zero] } },
  { rw [C.shape i j hij, zero_comp] }
end

lemma ext {C₁ C₂ : homological_complex V c} (h_X : C₁.X = C₂.X)
  (h_d : ∀ (i j : ι), c.rel i j → C₁.d i j ≫ eq_to_hom (congr_fun h_X j) =
    eq_to_hom (congr_fun h_X i) ≫ C₂.d i j) : C₁ = C₂ :=
begin
  cases C₁,
  cases C₂,
  dsimp at h_X,
  subst h_X,
  simp only [true_and, eq_self_iff_true, heq_iff_eq],
  ext i j,
  by_cases hij : c.rel i j,
  { simpa only [id_comp, eq_to_hom_refl, comp_id] using h_d i j hij, },
  { rw [C₁_shape' i j hij, C₂_shape' i j hij], }
end

end homological_complex

/--
An `α`-indexed chain complex is a `homological_complex`
in which `d i j ≠ 0` only if `j + 1 = i`.
-/
abbreviation chain_complex (α : Type*) [add_right_cancel_semigroup α] [has_one α] : Type* :=
homological_complex V (complex_shape.down α)

/--
An `α`-indexed cochain complex is a `homological_complex`
in which `d i j ≠ 0` only if `i + 1 = j`.
-/
abbreviation cochain_complex (α : Type*) [add_right_cancel_semigroup α] [has_one α] : Type* :=
homological_complex V (complex_shape.up α)

namespace chain_complex

@[simp] lemma prev (α : Type*) [add_right_cancel_semigroup α] [has_one α] (i : α) :
  (complex_shape.down α).prev i = some ⟨i+1, rfl⟩ :=
option.choice_eq _

@[simp] lemma next (α : Type*) [add_group α] [has_one α] (i : α) :
  (complex_shape.down α).next i = some ⟨i-1, sub_add_cancel i 1⟩ :=
option.choice_eq _

@[simp] lemma next_nat_zero :
  (complex_shape.down ℕ).next 0 = none :=
@option.choice_eq_none _ ⟨by rintro ⟨j, ⟨⟩⟩⟩

@[simp] lemma next_nat_succ (i : ℕ) :
  (complex_shape.down ℕ).next (i+1) = some ⟨i, rfl⟩ :=
option.choice_eq _

end chain_complex

namespace cochain_complex

@[simp] lemma prev (α : Type*) [add_group α] [has_one α] (i : α) :
  (complex_shape.up α).prev i = some ⟨i-1, sub_add_cancel i 1⟩ :=
option.choice_eq _

@[simp] lemma next (α : Type*) [add_right_cancel_semigroup α] [has_one α] (i : α) :
  (complex_shape.up α).next i = some ⟨i+1, rfl⟩ :=
option.choice_eq _

@[simp] lemma prev_nat_zero :
  (complex_shape.up ℕ).prev 0 = none :=
@option.choice_eq_none _ ⟨by rintro ⟨j, ⟨⟩⟩⟩

@[simp] lemma prev_nat_succ (i : ℕ) :
  (complex_shape.up ℕ).prev (i+1) = some ⟨i, rfl⟩ :=
option.choice_eq _

end cochain_complex

namespace homological_complex
variables {V} {c : complex_shape ι} (C : homological_complex V c)

/--
A morphism of homological complexes consists of maps between the chain groups,
commuting with the differentials.
-/
@[ext] structure hom (A B : homological_complex V c) :=
(f : ∀ i, A.X i ⟶ B.X i)
(comm' : ∀ i j, c.rel i j → f i ≫ B.d i j = A.d i j ≫ f j . obviously)

@[simp, reassoc]
lemma hom.comm {A B : homological_complex V c} (f : A.hom B) (i j : ι) :
  f.f i ≫ B.d i j = A.d i j ≫ f.f j :=
begin
  by_cases hij : c.rel i j,
  { exact f.comm' i j hij },
  rw [A.shape i j hij, B.shape i j hij, comp_zero, zero_comp],
end

instance (A B : homological_complex V c) : inhabited (hom A B) :=
⟨{ f := λ i, 0 }⟩

/-- Identity chain map. -/
def id (A : homological_complex V c) : hom A A :=
{ f := λ _, 𝟙 _ }

/-- Composition of chain maps. -/
def comp (A B C : homological_complex V c) (φ : hom A B) (ψ : hom B C) : hom A C :=
{ f := λ i, φ.f i ≫ ψ.f i }

section
local attribute [simp] id comp

instance : category (homological_complex V c) :=
{ hom := hom,
  id := id,
  comp := comp }

end

@[simp]

@[simp]
lemma eq_to_hom_f {C₁ C₂ : homological_complex V c} (h : C₁ = C₂) (n : ι) :
  homological_complex.hom.f (eq_to_hom h) n =
  eq_to_hom (congr_fun (congr_arg homological_complex.X h) n) :=
by { subst h, refl, }

-- We'll use this later to show that `homological_complex V c` is preadditive when `V` is.
lemma hom_f_injective {C₁ C₂ : homological_complex V c} :
  function.injective (λ f : hom C₁ C₂, f.f) :=
by tidy

instance : has_zero_morphisms (homological_complex V c) :=
{ has_zero := λ C D, ⟨{ f := λ i, 0 }⟩ }

@[simp] lemma zero_apply (C D : homological_complex V c) (i : ι) :
  (0 : C ⟶ D).f i = 0 := rfl

open_locale zero_object

instance [has_zero_object V] : has_zero_object (homological_complex V c) :=
{ zero :=
  { X := λ i, 0,
    d := λ i j, 0 },
  unique_from := λ C, ⟨⟨0⟩, λ f, by ext⟩,
  unique_to := λ C, ⟨⟨0⟩, λ f, by ext⟩ }

instance [has_zero_object V] : inhabited (homological_complex V c) := ⟨0⟩

lemma congr_hom {C D : homological_complex V c} {f g : C ⟶ D} (w : f = g) (i : ι) : f.f i = g.f i :=
congr_fun (congr_arg hom.f w) i

section
variables (V c)

/-- The functor picking out the `i`-th object of a complex. -/
@[simps] def eval (i : ι) : homological_complex V c ⥤ V :=
{ obj := λ C, C.X i,
  map := λ C D f, f.f i, }

/-- The functor forgetting the differential in a complex, obtaining a graded object. -/
@[simps] def forget : homological_complex V c ⥤ graded_object ι V :=
{ obj := λ C, C.X,
  map := λ _ _ f, f.f }

/-- Forgetting the differentials than picking out the `i`-th object is the same as
just picking out the `i`-th object. -/
@[simps] def forget_eval (i : ι) : forget V c ⋙ graded_object.eval i ≅ eval V c i :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

end

open_locale classical
noncomputable theory

/--
If `C.d i j` and `C.d i j'` are both allowed, then we must have `j = j'`,
and so the differentials only differ by an `eq_to_hom`.
-/
@[simp] lemma d_comp_eq_to_hom {i j j' : ι} (rij : c.rel i j) (rij' : c.rel i j') :
  C.d i j' ≫ eq_to_hom (congr_arg C.X (c.next_eq rij' rij)) = C.d i j :=
begin
  have P : ∀ h : j' = j, C.d i j' ≫ eq_to_hom (congr_arg C.X h) = C.d i j,
  { rintro rfl, simp },
  apply P,
end

/--
If `C.d i j` and `C.d i' j` are both allowed, then we must have `i = i'`,
and so the differentials only differ by an `eq_to_hom`.
-/
@[simp] lemma eq_to_hom_comp_d {i i' j : ι} (rij : c.rel i j) (rij' : c.rel i' j) :
  eq_to_hom (congr_arg C.X (c.prev_eq rij rij')) ≫ C.d i' j = C.d i j :=
begin
  have P : ∀ h : i = i', eq_to_hom (congr_arg C.X h) ≫ C.d i' j = C.d i j,
  { rintro rfl, simp },
  apply P,
end

lemma kernel_eq_kernel [has_kernels V] {i j j' : ι} (r : c.rel i j) (r' : c.rel i j') :
  kernel_subobject (C.d i j) = kernel_subobject (C.d i j') :=
begin
  rw ←d_comp_eq_to_hom C r r',
  apply kernel_subobject_comp_mono,
end

lemma image_eq_image [has_images V] [has_equalizers V]
  {i i' j : ι} (r : c.rel i j) (r' : c.rel i' j) :
  image_subobject (C.d i j) = image_subobject (C.d i' j) :=
begin
  rw ←eq_to_hom_comp_d C r r',
  apply image_subobject_iso_comp,
end

section

variables [has_zero_object V]
open_locale zero_object

/-- Either `C.X i`, if there is some `i` with `c.rel i j`, or the zero object. -/
def X_prev (j : ι) : V :=
match c.prev j with
| none := 0
| (some ⟨i,_⟩) := C.X i
end

/-- If `c.rel i j`, then `C.X_prev j` is isomorphic to `C.X i`. -/
def X_prev_iso {i j : ι} (r : c.rel i j) :
  C.X_prev j ≅ C.X i :=
eq_to_iso begin
  dsimp [X_prev],
  rw c.prev_eq_some r,
  refl,
end

/-- If there is no `i` so `c.rel i j`, then `C.X_prev j` is isomorphic to `0`. -/
def X_prev_iso_zero {j : ι} (h : c.prev j = none) :
  C.X_prev j ≅ 0 :=
eq_to_iso begin
  dsimp [X_prev],
  rw h,
  refl,
end

/-- Either `C.X j`, if there is some `j` with `c.rel i j`, or the zero object. -/
def X_next (i : ι) : V :=
match c.next i with
| none := 0
| (some ⟨j,_⟩) := C.X j
end

/-- If `c.rel i j`, then `C.X_next i` is isomorphic to `C.X j`. -/
def X_next_iso {i j : ι} (r : c.rel i j) :
  C.X_next i ≅ C.X j :=
eq_to_iso begin
  dsimp [X_next],
  rw c.next_eq_some r,
  refl,
end

/-- If there is no `j` so `c.rel i j`, then `C.X_next i` is isomorphic to `0`. -/
def X_next_iso_zero {i : ι} (h : c.next i = none) :
  C.X_next i ≅ 0 :=
eq_to_iso begin
  dsimp [X_next],
  rw h,
  refl,
end

/--
The differential mapping into `C.X j`, or zero if there isn't one.
-/
def d_to (j : ι) : C.X_prev j ⟶ C.X j :=
match c.prev j with
| none := (0 : C.X_prev j ⟶ C.X j)
| (some ⟨i, w⟩) := (C.X_prev_iso w).hom ≫ C.d i j
end

/--
The differential mapping out of `C.X i`, or zero if there isn't one.
-/
def d_from (i : ι) : C.X i ⟶ C.X_next i :=
match c.next i with
| none := (0 : C.X i ⟶ C.X_next i)
| (some ⟨j, w⟩) := C.d i j ≫ (C.X_next_iso w).inv
end

lemma d_to_eq {i j : ι} (r : c.rel i j) :
  C.d_to j = (C.X_prev_iso r).hom ≫ C.d i j :=
begin
  dsimp [d_to, X_prev_iso],
  rw c.prev_eq_some r,
  refl,
end

@[simp]
lemma d_to_eq_zero {j : ι} (h : c.prev j = none) :
  C.d_to j = 0 :=
begin
  dsimp [d_to],
  rw h, refl,
end

lemma d_from_eq {i j : ι} (r : c.rel i j) :
  C.d_from i = C.d i j ≫ (C.X_next_iso r).inv :=
begin
  dsimp [d_from, X_next_iso],
  rw c.next_eq_some r,
  refl,
end

@[simp]
lemma d_from_eq_zero {i : ι} (h : c.next i = none) :
  C.d_from i = 0 :=
begin
  dsimp [d_from],
  rw h, refl,
end

@[simp, reassoc] lemma X_prev_iso_comp_d_to {i j : ι} (r : c.rel i j) :
  (C.X_prev_iso r).inv ≫ C.d_to j = C.d i j :=
by simp [C.d_to_eq r]

@[simp, reassoc] lemma X_prev_iso_zero_comp_d_to {j : ι} (h : c.prev j = none) :
  (C.X_prev_iso_zero h).inv ≫ C.d_to j = 0 :=
by simp [h]

@[simp, reassoc] lemma d_from_comp_X_next_iso {i j : ι} (r : c.rel i j) :
  C.d_from i ≫ (C.X_next_iso r).hom = C.d i j :=
by simp [C.d_from_eq r]

@[simp, reassoc] lemma d_from_comp_X_next_iso_zero {i : ι} (h : c.next i = none) :
  C.d_from i ≫ (C.X_next_iso_zero h).hom = 0 :=
by simp [h]

@[simp]
lemma d_to_comp_d_from (j : ι) : C.d_to j ≫ C.d_from j = 0 :=
begin
  rcases h₁ : c.next j with _ | ⟨k,w₁⟩,
  { rw [d_from_eq_zero _ h₁], simp },
  { rw [d_from_eq _ w₁],
    rcases h₂ : c.prev j with _ | ⟨i,w₂⟩,
    { rw [d_to_eq_zero _ h₂], simp },
    { rw [d_to_eq _ w₂], simp } }
end

lemma kernel_from_eq_kernel [has_kernels V] {i j : ι} (r : c.rel i j) :
  kernel_subobject (C.d_from i) = kernel_subobject (C.d i j) :=
begin
  rw C.d_from_eq r,
  apply kernel_subobject_comp_mono,
end

lemma image_to_eq_image [has_images V] [has_equalizers V]
  {i j : ι} (r : c.rel i j) :
  image_subobject (C.d_to j) = image_subobject (C.d i j) :=
begin
  rw C.d_to_eq r,
  apply image_subobject_iso_comp,
end

end

namespace hom

variables {C₁ C₂ C₃ : homological_complex V c}

/-- The `i`-th component of an isomorphism of chain complexes. -/
@[simps]
def iso_app (f : C₁ ≅ C₂) (i : ι) : C₁.X i ≅ C₂.X i :=
(eval V c i).map_iso f

/-- Construct an isomorphism of chain complexes from isomorphism of the objects
which commute with the differentials. -/
@[simps]
def iso_of_components (f : Π i, C₁.X i ≅ C₂.X i)
  (hf : ∀ i j, c.rel i j → (f i).hom ≫ C₂.d i j = C₁.d i j ≫ (f j).hom) :
  C₁ ≅ C₂ :=
{ hom := { f := λ i, (f i).hom, comm' := hf },
  inv :=
  { f := λ i, (f i).inv,
    comm' := λ i j hij,
    calc (f i).inv ≫ C₁.d i j
        = (f i).inv ≫ (C₁.d i j ≫ (f j).hom) ≫ (f j).inv : by simp
    ... = (f i).inv ≫ ((f i).hom ≫ C₂.d i j) ≫ (f j).inv : by rw hf i j hij
    ... =  C₂.d i j ≫ (f j).inv : by simp },
  hom_inv_id' := by { ext i, exact (f i).hom_inv_id },
  inv_hom_id' := by { ext i, exact (f i).inv_hom_id } }

@[simp] lemma iso_of_components_app (f : Π i, C₁.X i ≅ C₂.X i)
  (hf : ∀ i j, c.rel i j → (f i).hom ≫ C₂.d i j = C₁.d i j ≫ (f j).hom) (i : ι) :
  iso_app (iso_of_components f hf) i = f i :=
by { ext, simp, }

variables [has_zero_object V]
open_locale zero_object

/-! Lemmas relating chain maps and `d_to`/`d_from`. -/

/-- `f.prev j` is `f.f i` if there is some `r i j`, and zero otherwise. -/
def prev (f : hom C₁ C₂) (j : ι) : C₁.X_prev j ⟶ C₂.X_prev j :=
match c.prev j with
| none := 0
| some ⟨i,w⟩ := (C₁.X_prev_iso w).hom ≫ f.f i ≫ (C₂.X_prev_iso w).inv
end

lemma prev_eq (f : hom C₁ C₂) {i j : ι} (w : c.rel i j) :
  f.prev j = (C₁.X_prev_iso w).hom ≫ f.f i ≫ (C₂.X_prev_iso w).inv :=
begin
  dsimp [prev],
  rw c.prev_eq_some w,
  refl,
end

/-- `f.next i` is `f.f j` if there is some `r i j`, and zero otherwise. -/
def next (f : hom C₁ C₂) (i : ι) : C₁.X_next i ⟶ C₂.X_next i :=
match c.next i with
| none := 0
| some ⟨j,w⟩ := (C₁.X_next_iso w).hom ≫ f.f j ≫ (C₂.X_next_iso w).inv
end

lemma next_eq (f : hom C₁ C₂) {i j : ι} (w : c.rel i j) :
  f.next i = (C₁.X_next_iso w).hom ≫ f.f j ≫ (C₂.X_next_iso w).inv :=
begin
  dsimp [next],
  rw c.next_eq_some w,
  refl,
end

@[simp, reassoc, elementwise]
lemma comm_from (f : hom C₁ C₂) (i : ι) :
  f.f i ≫ C₂.d_from i = C₁.d_from i ≫ f.next i :=
begin
  rcases h : c.next i with _ | ⟨j,w⟩,
  { simp [h] },
  { simp [d_from_eq _ w, next_eq _ w] }
end

@[simp, reassoc, elementwise]
lemma comm_to (f : hom C₁ C₂) (j : ι) :
  f.prev j ≫ C₂.d_to j = C₁.d_to j ≫ f.f j :=
begin
  rcases h : c.prev j with _ | ⟨j,w⟩,
  { simp [h] },
  { simp [d_to_eq _ w, prev_eq _ w] }
end

/--
A morphism of chain complexes
induces a morphism of arrows of the differentials out of each object.
-/
def sq_from (f : hom C₁ C₂) (i : ι) : arrow.mk (C₁.d_from i) ⟶ arrow.mk (C₂.d_from i) :=
arrow.hom_mk (f.comm_from i)

@[simp] lemma sq_from_left (f : hom C₁ C₂) (i : ι) : (f.sq_from i).left = f.f i := rfl
@[simp] lemma sq_from_right (f : hom C₁ C₂) (i : ι) : (f.sq_from i).right = f.next i := rfl

@[simp] lemma sq_from_id (C₁ : homological_complex V c) (i : ι) : sq_from (𝟙 C₁) i = 𝟙 _ :=
begin
  rcases h : c.next i with _ | ⟨j,w⟩,
  { ext,
    { refl },
    { dsimp, simp only [next, h],
      symmetry,
      apply zero_of_target_iso_zero,
      exact X_next_iso_zero _ h } },
  { ext, refl, dsimp, simp [next, h] }
end

@[simp] lemma sq_from_comp (f : C₁ ⟶ C₂) (g : C₂ ⟶ C₃) (i : ι) :
  sq_from (f ≫ g) i = sq_from f i ≫ sq_from g i :=
begin
  rcases h : c.next i with _ | ⟨j,w⟩,
  { ext,
    { refl },
    { dsimp, simp only [next, h],
      symmetry,
      apply zero_of_target_iso_zero,
      exact X_next_iso_zero _ h } },
  { ext, refl, dsimp, simp [next, h] }
end

/--
A morphism of chain complexes
induces a morphism of arrows of the differentials into each object.
-/
def sq_to (f : hom C₁ C₂) (j : ι) : arrow.mk (C₁.d_to j) ⟶ arrow.mk (C₂.d_to j) :=
arrow.hom_mk (f.comm_to j)

@[simp] lemma sq_to_left (f : hom C₁ C₂) (j : ι) : (f.sq_to j).left = f.prev j := rfl
@[simp] lemma sq_to_right (f : hom C₁ C₂) (j : ι) : (f.sq_to j).right = f.f j := rfl

end hom

end homological_complex

namespace chain_complex

section of
variables {V} {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

/--
Construct an `α`-indexed chain complex from a dependently-typed differential.
-/
def of (X : α → V) (d : Π n, X (n+1) ⟶ X n) (sq : ∀ n, d (n+1) ≫ d n = 0) : chain_complex V α :=
{ X := X,
  d := λ i j, if h : i = j + 1 then
    eq_to_hom (by subst h) ≫ d j
  else
    0,
  shape' := λ i j w, by rw dif_neg (ne.symm w),
  d_comp_d' := λ i j k hij hjk,
  begin
    dsimp at hij hjk, substs hij hjk,
    simp only [category.id_comp, dif_pos rfl, eq_to_hom_refl],
    exact sq k,
  end }

variables (X : α → V) (d : Π n, X (n+1) ⟶ X n) (sq : ∀ n, d (n+1) ≫ d n = 0)

@[simp] lemma of_X (n : α) : (of X d sq).X n = X n := rfl
@[simp] lemma of_d (j : α) : (of X d sq).d (j+1) j = d j :=
by { dsimp [of], rw [if_pos rfl, category.id_comp] }
lemma of_d_ne {i j : α} (h : i ≠ j + 1) : (of X d sq).d i j = 0 :=
by { dsimp [of], rw [dif_neg h], }

end of

section of_hom

variables {V} {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

variables (X : α → V) (d_X : Π n, X (n+1) ⟶ X n) (sq_X : ∀ n, d_X (n+1) ≫ d_X n = 0)
  (Y : α → V) (d_Y : Π n, Y (n+1) ⟶ Y n) (sq_Y : ∀ n, d_Y (n+1) ≫ d_Y n = 0)

/--
A constructor for chain maps between `α`-indexed chain complexes built using `chain_complex.of`,
from a dependently typed collection of morphisms.
-/
@[simps] def of_hom (f : Π i : α, X i ⟶ Y i) (comm : ∀ i : α, f (i+1) ≫ d_Y i = d_X i ≫ f i) :
  of X d_X sq_X ⟶ of Y d_Y sq_Y :=
{ f := f,
  comm' := λ n m,
  begin
    by_cases h : n = m + 1,
    { subst h,
      simpa using comm m, },
    { rw [of_d_ne X _ _ h, of_d_ne Y _ _ h], simp }
  end }

end of_hom

section mk

/--
Auxiliary structure for setting up the recursion in `mk`.
This is purely an implementation detail: for some reason just using the dependent 6-tuple directly
results in `mk_aux` taking much longer (well over the `-T100000` limit) to elaborate.
-/
@[nolint has_inhabited_instance]
structure mk_struct :=
(X₀ X₁ X₂ : V)
(d₀ : X₁ ⟶ X₀)
(d₁ : X₂ ⟶ X₁)
(s : d₁ ≫ d₀ = 0)

variables {V}

/-- Flatten to a tuple. -/
def mk_struct.flat (t : mk_struct V) :
  Σ' (X₀ X₁ X₂ : V) (d₀ : X₁ ⟶ X₀) (d₁ : X₂ ⟶ X₁), d₁ ≫ d₀ = 0 :=
⟨t.X₀, t.X₁, t.X₂, t.d₀, t.d₁, t.s⟩

variables (X₀ X₁ X₂ : V) (d₀ : X₁ ⟶ X₀) (d₁ : X₂ ⟶ X₁) (s : d₁ ≫ d₀ = 0)
  (succ : Π (t : Σ' (X₀ X₁ X₂ : V) (d₀ : X₁ ⟶ X₀) (d₁ : X₂ ⟶ X₁), d₁ ≫ d₀ = 0),
    Σ' (X₃ : V) (d₂ : X₃ ⟶ t.2.2.1), d₂ ≫ t.2.2.2.2.1 = 0)

/-- Auxiliary definition for `mk`. -/
def mk_aux :
  Π n : ℕ, mk_struct V
| 0 := ⟨X₀, X₁, X₂, d₀, d₁, s⟩
| (n+1) :=
  let p := mk_aux n in
  ⟨p.X₁, p.X₂, (succ p.flat).1, p.d₁, (succ p.flat).2.1, (succ p.flat).2.2⟩

/--
A inductive constructor for `ℕ`-indexed chain complexes.

You provide explicitly the first two differentials,
then a function which takes two differentials and the fact they compose to zero,
and returns the next object, its differential, and the fact it composes appropiately to zero.

See also `mk'`, which only sees the previous differential in the inductive step.
-/
def mk : chain_complex V ℕ :=
of (λ n, (mk_aux X₀ X₁ X₂ d₀ d₁ s succ n).X₀) (λ n, (mk_aux X₀ X₁ X₂ d₀ d₁ s succ n).d₀)
  (λ n, (mk_aux X₀ X₁ X₂ d₀ d₁ s succ n).s)

@[simp] lemma mk_X_0 : (mk X₀ X₁ X₂ d₀ d₁ s succ).X 0 = X₀ := rfl
@[simp] lemma mk_X_1 : (mk X₀ X₁ X₂ d₀ d₁ s succ).X 1 = X₁ := rfl
@[simp] lemma mk_X_2 : (mk X₀ X₁ X₂ d₀ d₁ s succ).X 2 = X₂ := rfl
@[simp] lemma mk_d_1_0 : (mk X₀ X₁ X₂ d₀ d₁ s succ).d 1 0 = d₀ :=
by { change ite (1 = 0 + 1) (𝟙 X₁ ≫ d₀) 0 = d₀, rw [if_pos rfl, category.id_comp] }
@[simp] lemma mk_d_2_0 : (mk X₀ X₁ X₂ d₀ d₁ s succ).d 2 1 = d₁ :=
by { change ite (2 = 1 + 1) (𝟙 X₂ ≫ d₁) 0 = d₁, rw [if_pos rfl, category.id_comp] }
-- TODO simp lemmas for the inductive steps? It's not entirely clear that they are needed.

/--
A simpler inductive constructor for `ℕ`-indexed chain complexes.

You provide explicitly the first differential,
then a function which takes a differential,
and returns the next object, its differential, and the fact it composes appropriately to zero.
-/
def mk' (X₀ X₁ : V) (d : X₁ ⟶ X₀)
  (succ' : Π (t : Σ (X₀ X₁ : V), X₁ ⟶ X₀), Σ' (X₂ : V) (d : X₂ ⟶ t.2.1), d ≫ t.2.2 = 0) :
  chain_complex V ℕ :=
mk X₀ X₁ (succ' ⟨X₀, X₁, d⟩).1 d (succ' ⟨X₀, X₁, d⟩).2.1 (succ' ⟨X₀, X₁, d⟩).2.2
  (λ t, succ' ⟨t.2.1, t.2.2.1, t.2.2.2.2.1⟩)

variables (succ' : Π (t : Σ (X₀ X₁ : V), X₁ ⟶ X₀), Σ' (X₂ : V) (d : X₂ ⟶ t.2.1), d ≫ t.2.2 = 0)

@[simp] lemma mk'_X_0 : (mk' X₀ X₁ d₀ succ').X 0 = X₀ := rfl
@[simp] lemma mk'_X_1 : (mk' X₀ X₁ d₀ succ').X 1 = X₁ := rfl
@[simp] lemma mk'_d_1_0 : (mk' X₀ X₁ d₀ succ').d 1 0 = d₀ :=
by { change ite (1 = 0 + 1) (𝟙 X₁ ≫ d₀) 0 = d₀, rw [if_pos rfl, category.id_comp] }
-- TODO simp lemmas for the inductive steps? It's not entirely clear that they are needed.

end mk

section mk_hom

variables {V} (P Q : chain_complex V ℕ)
  (zero : P.X 0 ⟶ Q.X 0)
  (one : P.X 1 ⟶ Q.X 1)
  (one_zero_comm : one ≫ Q.d 1 0 = P.d 1 0 ≫ zero)
  (succ : ∀ (n : ℕ)
    (p : Σ' (f : P.X n ⟶ Q.X n) (f' : P.X (n+1) ⟶ Q.X (n+1)), f' ≫ Q.d (n+1) n = P.d (n+1) n ≫ f),
    Σ' f'' : P.X (n+2) ⟶ Q.X (n+2), f'' ≫ Q.d (n+2) (n+1) = P.d (n+2) (n+1) ≫ p.2.1)

/--
An auxiliary construction for `mk_hom`.

Here we build by induction a family of commutative squares,
but don't require at the type level that these successive commutative squares actually agree.
They do in fact agree, and we then capture that at the type level (i.e. by constructing a chain map)
in `mk_hom`.
-/
def mk_hom_aux :
  Π n, Σ' (f : P.X n ⟶ Q.X n) (f' : P.X (n+1) ⟶ Q.X (n+1)), f' ≫ Q.d (n+1) n = P.d (n+1) n ≫ f
| 0 := ⟨zero, one, one_zero_comm⟩
| (n+1) := ⟨(mk_hom_aux n).2.1,
    (succ n (mk_hom_aux n)).1, (succ n (mk_hom_aux n)).2⟩

/--
A constructor for chain maps between `ℕ`-indexed chain complexes,
working by induction on commutative squares.

You need to provide the components of the chain map in degrees 0 and 1,
show that these form a commutative square,
and then give a construction of each component,
and the fact that it forms a commutative square with the previous component,
using as an inductive hypothesis the data (and commutativity) of the previous two components.
-/
def mk_hom : P ⟶ Q :=
{ f := λ n, (mk_hom_aux P Q zero one one_zero_comm succ n).1,
  comm' := λ n m,
  begin
    rintro (rfl : m + 1 = n),
    exact (mk_hom_aux P Q zero one one_zero_comm succ m).2.2,
  end }

@[simp] lemma mk_hom_f_0 : (mk_hom P Q zero one one_zero_comm succ).f 0 = zero := rfl
@[simp] lemma mk_hom_f_1 : (mk_hom P Q zero one one_zero_comm succ).f 1 = one := rfl
@[simp] lemma mk_hom_f_succ_succ (n : ℕ) :
  (mk_hom P Q zero one one_zero_comm succ).f (n+2) =
    (succ n ⟨(mk_hom P Q zero one one_zero_comm succ).f n,
      (mk_hom P Q zero one one_zero_comm succ).f (n+1),
        (mk_hom P Q zero one one_zero_comm succ).comm (n+1) n⟩).1 :=
begin
  dsimp [mk_hom, mk_hom_aux],
  induction n; congr,
end

end mk_hom

end chain_complex

namespace cochain_complex

section of
variables {V} {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

/--
Construct an `α`-indexed cochain complex from a dependently-typed differential.
-/
def of (X : α → V) (d : Π n, X n ⟶ X (n+1)) (sq : ∀ n, d n ≫ d (n+1) = 0) : cochain_complex V α :=
{ X := X,
  d := λ i j, if h : i + 1 = j then
    d _ ≫ eq_to_hom (by subst h)
  else
    0,
  shape' := λ i j w, by {rw dif_neg, exact w},
  d_comp_d' := λ i j k,
  begin
    split_ifs with h h' h',
    { substs h h',
      simp [sq] },
    all_goals { simp },
  end }

variables (X : α → V) (d : Π n, X n ⟶ X (n+1)) (sq : ∀ n, d n ≫ d (n+1) = 0)

@[simp] lemma of_X (n : α) : (of X d sq).X n = X n := rfl
@[simp] lemma of_d (j : α) : (of X d sq).d j (j+1) = d j :=
by { dsimp [of], rw [if_pos rfl, category.comp_id] }
lemma of_d_ne {i j : α} (h : i + 1 ≠ j) : (of X d sq).d i j = 0 :=
by { dsimp [of], rw [dif_neg h] }

end of

section of_hom

variables {V} {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

variables (X : α → V) (d_X : Π n, X n ⟶ X (n+1)) (sq_X : ∀ n, d_X n ≫ d_X (n+1) = 0)
  (Y : α → V) (d_Y : Π n, Y n ⟶ Y (n+1)) (sq_Y : ∀ n, d_Y n ≫ d_Y (n+1) = 0)

/--
A constructor for chain maps between `α`-indexed cochain complexes built using `cochain_complex.of`,
from a dependently typed collection of morphisms.
-/
@[simps] def of_hom (f : Π i : α, X i ⟶ Y i) (comm : ∀ i : α, f i ≫ d_Y i = d_X i ≫ f (i+1)) :
  of X d_X sq_X ⟶ of Y d_Y sq_Y :=
{ f := f,
  comm' := λ n m,
  begin
    by_cases h : n + 1 = m,
    { subst h,
      simpa using comm n },
    { rw [of_d_ne X _ _ h, of_d_ne Y _ _ h], simp }
  end }

end of_hom

section mk

/--
Auxiliary structure for setting up the recursion in `mk`.
This is purely an implementation detail: for some reason just using the dependent 6-tuple directly
results in `mk_aux` taking much longer (well over the `-T100000` limit) to elaborate.
-/
@[nolint has_inhabited_instance]
structure mk_struct :=
(X₀ X₁ X₂ : V)
(d₀ : X₀ ⟶ X₁)
(d₁ : X₁ ⟶ X₂)
(s : d₀ ≫ d₁ = 0)

variables {V}

/-- Flatten to a tuple. -/
def mk_struct.flat (t : mk_struct V) :
  Σ' (X₀ X₁ X₂ : V) (d₀ : X₀ ⟶ X₁) (d₁ : X₁ ⟶ X₂), d₀ ≫ d₁ = 0 :=
⟨t.X₀, t.X₁, t.X₂, t.d₀, t.d₁, t.s⟩

variables (X₀ X₁ X₂ : V) (d₀ : X₀ ⟶ X₁) (d₁ : X₁ ⟶ X₂) (s : d₀ ≫ d₁ = 0)
  (succ : Π (t : Σ' (X₀ X₁ X₂ : V) (d₀ : X₀ ⟶ X₁) (d₁ : X₁ ⟶ X₂), d₀ ≫ d₁ = 0),
    Σ' (X₃ : V) (d₂ : t.2.2.1 ⟶ X₃), t.2.2.2.2.1 ≫ d₂ = 0)

/-- Auxiliary definition for `mk`. -/
def mk_aux :
  Π n : ℕ, mk_struct V
| 0 := ⟨X₀, X₁, X₂, d₀, d₁, s⟩
| (n+1) :=
  let p := mk_aux n in
  ⟨p.X₁, p.X₂, (succ p.flat).1, p.d₁, (succ p.flat).2.1, (succ p.flat).2.2⟩

/--
A inductive constructor for `ℕ`-indexed cochain complexes.

You provide explicitly the first two differentials,
then a function which takes two differentials and the fact they compose to zero,
and returns the next object, its differential, and the fact it composes appropiately to zero.

See also `mk'`, which only sees the previous differential in the inductive step.
-/
def mk : cochain_complex V ℕ :=
of (λ n, (mk_aux X₀ X₁ X₂ d₀ d₁ s succ n).X₀) (λ n, (mk_aux X₀ X₁ X₂ d₀ d₁ s succ n).d₀)
  (λ n, (mk_aux X₀ X₁ X₂ d₀ d₁ s succ n).s)

@[simp] lemma mk_X_0 : (mk X₀ X₁ X₂ d₀ d₁ s succ).X 0 = X₀ := rfl
@[simp] lemma mk_X_1 : (mk X₀ X₁ X₂ d₀ d₁ s succ).X 1 = X₁ := rfl
@[simp] lemma mk_X_2 : (mk X₀ X₁ X₂ d₀ d₁ s succ).X 2 = X₂ := rfl
@[simp] lemma mk_d_1_0 : (mk X₀ X₁ X₂ d₀ d₁ s succ).d 0 1 = d₀ :=
by { change ite (1 = 0 + 1) (d₀ ≫ 𝟙 X₁) 0 = d₀, rw [if_pos rfl, category.comp_id] }
@[simp] lemma mk_d_2_0 : (mk X₀ X₁ X₂ d₀ d₁ s succ).d 1 2 = d₁ :=
by { change ite (2 = 1 + 1) (d₁ ≫ 𝟙 X₂) 0 = d₁, rw [if_pos rfl, category.comp_id] }
-- TODO simp lemmas for the inductive steps? It's not entirely clear that they are needed.

/--
A simpler inductive constructor for `ℕ`-indexed cochain complexes.

You provide explicitly the first differential,
then a function which takes a differential,
and returns the next object, its differential, and the fact it composes appropriately to zero.
-/
def mk' (X₀ X₁ : V) (d : X₀ ⟶ X₁)
  (succ' : Π (t : Σ (X₀ X₁ : V), X₀ ⟶ X₁), Σ' (X₂ : V) (d : t.2.1 ⟶ X₂), t.2.2 ≫ d = 0) :
  cochain_complex V ℕ :=
mk X₀ X₁ (succ' ⟨X₀, X₁, d⟩).1 d (succ' ⟨X₀, X₁, d⟩).2.1 (succ' ⟨X₀, X₁, d⟩).2.2
  (λ t, succ' ⟨t.2.1, t.2.2.1, t.2.2.2.2.1⟩)

variables (succ' : Π (t : Σ (X₀ X₁ : V), X₀ ⟶ X₁), Σ' (X₂ : V) (d : t.2.1 ⟶ X₂), t.2.2 ≫ d = 0)

@[simp] lemma mk'_X_0 : (mk' X₀ X₁ d₀ succ').X 0 = X₀ := rfl
@[simp] lemma mk'_X_1 : (mk' X₀ X₁ d₀ succ').X 1 = X₁ := rfl
@[simp] lemma mk'_d_1_0 : (mk' X₀ X₁ d₀ succ').d 0 1 = d₀ :=
by { change ite (1 = 0 + 1) (d₀ ≫ 𝟙 X₁) 0 = d₀, rw [if_pos rfl, category.comp_id] }
-- TODO simp lemmas for the inductive steps? It's not entirely clear that they are needed.

end mk

section mk_hom

variables {V} (P Q : cochain_complex V ℕ)
  (zero : P.X 0 ⟶ Q.X 0)
  (one : P.X 1 ⟶ Q.X 1)
  (one_zero_comm : zero ≫ Q.d 0 1 = P.d 0 1 ≫ one)
  (succ : ∀ (n : ℕ)
    (p : Σ' (f : P.X n ⟶ Q.X n) (f' : P.X (n+1) ⟶ Q.X (n+1)), f ≫ Q.d n (n+1) = P.d n (n+1) ≫ f'),
    Σ' f'' : P.X (n+2) ⟶ Q.X (n+2), p.2.1 ≫ Q.d (n+1) (n+2) = P.d (n+1) (n+2) ≫ f'')

/--
An auxiliary construction for `mk_hom`.

Here we build by induction a family of commutative squares,
but don't require at the type level that these successive commutative squares actually agree.
They do in fact agree, and we then capture that at the type level (i.e. by constructing a chain map)
in `mk_hom`.
-/
def mk_hom_aux :
  Π n, Σ' (f : P.X n ⟶ Q.X n) (f' : P.X (n+1) ⟶ Q.X (n+1)), f ≫ Q.d n (n+1) = P.d n (n+1) ≫ f'
| 0 := ⟨zero, one, one_zero_comm⟩
| (n+1) := ⟨(mk_hom_aux n).2.1,
    (succ n (mk_hom_aux n)).1, (succ n (mk_hom_aux n)).2⟩

/--
A constructor for chain maps between `ℕ`-indexed cochain complexes,
working by induction on commutative squares.

You need to provide the components of the chain map in degrees 0 and 1,
show that these form a commutative square,
and then give a construction of each component,
and the fact that it forms a commutative square with the previous component,
using as an inductive hypothesis the data (and commutativity) of the previous two components.
-/
def mk_hom : P ⟶ Q :=
{ f := λ n, (mk_hom_aux P Q zero one one_zero_comm succ n).1,
  comm' := λ n m,
  begin
    rintro (rfl : n + 1 = m),
    exact (mk_hom_aux P Q zero one one_zero_comm succ n).2.2,
  end }

@[simp] lemma mk_hom_f_0 : (mk_hom P Q zero one one_zero_comm succ).f 0 = zero := rfl
@[simp] lemma mk_hom_f_1 : (mk_hom P Q zero one one_zero_comm succ).f 1 = one := rfl
@[simp] lemma mk_hom_f_succ_succ (n : ℕ) :
  (mk_hom P Q zero one one_zero_comm succ).f (n+2) =
    (succ n ⟨(mk_hom P Q zero one one_zero_comm succ).f n,
      (mk_hom P Q zero one one_zero_comm succ).f (n+1),
        (mk_hom P Q zero one one_zero_comm succ).comm n (n+1)⟩).1 :=
begin
  dsimp [mk_hom, mk_hom_aux],
  induction n; congr,
end

end mk_hom

end cochain_complex


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import analysis.normed_space.dual
import analysis.normed_space.star.basic
import analysis.complex.basic
import analysis.inner_product_space.adjoint
import algebra.star.subalgebra

/-!
# Von Neumann algebras

We give the "abstract" and "concrete" definitions of a von Neumann algebra.
We still have a major project ahead of us to show the equivalence between these definitions!

An abstract von Neumann algebra `wstar_algebra M` is a C^* algebra with a Banach space predual,
per Sakai (1971).

A concrete von Neumann algebra `von_neumann_algebra H` (where `H` is a Hilbert space)
is a *-closed subalgebra of bounded operators on `H` which is equal to its double commutant.

We'll also need to prove the von Neumann double commutant theorem,
that the concrete definition is equivalent to a *-closed subalgebra which is weakly closed.
-/

universes u v

/--
Sakai's definition of a von Neumann algebra as a C^* algebra with a Banach space predual.

So that we can unambiguously talk about these "abstract" von Neumann algebras
in parallel with the "concrete" ones (weakly closed *-subalgebras of B(H)),
we name this definition `wstar_algebra`.

Note that for now we only assert the mere existence of predual, rather than picking one.
This may later prove problematic, and need to be revisited.
Picking one may cause problems with definitional unification of different instances.
One the other hand, not picking one means that the weak-* topology
(which depends on a choice of predual) must be defined using the choice,
and we may be unhappy with the resulting opaqueness of the definition.
-/
class wstar_algebra (M : Type u) [normed_ring M] [star_ring M] [cstar_ring M]
  [module ℂ M] [normed_algebra ℂ M] [star_module ℂ M] :=
(exists_predual : ∃ (X : Type u) [normed_add_comm_group X] [normed_space ℂ X] [complete_space X],
  nonempty (normed_space.dual ℂ X ≃ₗᵢ⋆[ℂ] M))

-- TODO: Without this, `von_neumann_algebra` times out. Why?
set_option old_structure_cmd true

/--
The double commutant definition of a von Neumann algebra,
as a *-closed subalgebra of bounded operators on a Hilbert space,
which is equal to its double commutant.

Note that this definition is parameterised by the Hilbert space
on which the algebra faithfully acts, as is standard in the literature.
See `wstar_algebra` for the abstract notion (a C^*-algebra with Banach space predual).

Note this is a bundled structure, parameterised by the Hilbert space `H`,
rather than a typeclass on the type of elements.
Thus we can't say that the bounded operators `H →L[ℂ] H` form a `von_neumann_algebra`
(although we will later construct the instance `wstar_algebra (H →L[ℂ] H)`),
and instead will use `⊤ : von_neumann_algebra H`.
-/
@[nolint has_nonempty_instance]
structure von_neumann_algebra (H : Type u)
  [normed_add_comm_group H] [inner_product_space ℂ H] [complete_space H] extends
  star_subalgebra ℂ (H →L[ℂ] H) :=
(centralizer_centralizer' :
  set.centralizer (set.centralizer carrier) = carrier)

/--
Consider a von Neumann algebra acting on a Hilbert space `H` as a *-subalgebra of `H →L[ℂ] H`.
(That is, we forget that it is equal to its double commutant
or equivalently that it is closed in the weak and strong operator topologies.)
-/
add_decl_doc von_neumann_algebra.to_star_subalgebra

namespace von_neumann_algebra
variables {H : Type u} [normed_add_comm_group H] [inner_product_space ℂ H] [complete_space H]

instance : set_like (von_neumann_algebra H) (H →L[ℂ] H) :=
⟨von_neumann_algebra.carrier, λ S T h, by cases S; cases T; congr'⟩

instance : star_mem_class (von_neumann_algebra H) (H →L[ℂ] H) :=
{ star_mem := λ s a, s.star_mem' }

instance : subring_class (von_neumann_algebra H) (H →L[ℂ] H) :=
{ add_mem := add_mem',
  mul_mem := mul_mem',
  one_mem := one_mem',
  zero_mem := zero_mem' ,
  neg_mem := λ s a ha, show -a ∈ s.to_star_subalgebra, from neg_mem ha }

@[simp] lemma mem_carrier {S : von_neumann_algebra H} {x : H →L[ℂ] H}:
  x ∈ S.carrier ↔ x ∈ (S : set (H →L[ℂ] H)) := iff.rfl

@[ext] theorem ext {S T : von_neumann_algebra H} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
set_like.ext h

@[simp] lemma centralizer_centralizer (S : von_neumann_algebra H) :
  set.centralizer (set.centralizer (S : set (H →L[ℂ] H))) = S := S.centralizer_centralizer'

/-- The centralizer of a `von_neumann_algebra`, as a `von_neumann_algebra`.-/
def commutant (S : von_neumann_algebra H) : von_neumann_algebra H :=
{ carrier := set.centralizer (S : set (H →L[ℂ] H)),
  centralizer_centralizer' := by rw S.centralizer_centralizer,
  .. star_subalgebra.centralizer ℂ (S : set (H →L[ℂ] H)) (λ a (ha : a ∈ S), (star_mem ha : _)) }

@[simp] lemma coe_commutant (S : von_neumann_algebra H) :
  ↑S.commutant = set.centralizer (S : set (H →L[ℂ] H)) := rfl

@[simp] lemma mem_commutant_iff {S : von_neumann_algebra H} {z : H →L[ℂ] H} :
  z ∈ S.commutant ↔ ∀ g ∈ S, g * z = z * g :=
iff.rfl

@[simp] lemma commutant_commutant (S : von_neumann_algebra H) :
  S.commutant.commutant = S :=
set_like.coe_injective S.centralizer_centralizer'

end von_neumann_algebra


/-
Copyright (c) 2022 Alex J. Best. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex J. Best, Yaël Dillies

! This file was ported from Lean 3 source module algebra.order.complete_field
! leanprover-community/mathlib commit 402f8982dddc1864bd703da2d6e2ee304a866973
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Order.Hom.Ring
import Mathbin.Algebra.Order.Pointwise
import Mathbin.Analysis.SpecialFunctions.Pow

/-!
# Conditionally complete linear ordered fields

This file shows that the reals are unique, or, more formally, given a type satisfying the common
axioms of the reals (field, conditionally complete, linearly ordered) that there is an isomorphism
preserving these properties to the reals. This is `rat.induced_order_ring_iso`. Moreover this
isomorphism is unique.

We introduce definitions of conditionally complete linear ordered fields, and show all such are
archimedean. We also construct the natural map from a `linear_ordered_field` to such a field.

## Main definitions

* `conditionally_complete_linear_ordered_field`: A field satisfying the standard axiomatization of
  the real numbers, being a Dedekind complete and linear ordered field.
* `linear_ordered_field.induced_map`: A (unique) map from any archimedean linear ordered field to a
  conditionally complete linear ordered field. Various bundlings are available.

## Main results

* `unique.order_ring_hom` : Uniqueness of `order_ring_hom`s from an archimedean linear ordered field
  to a conditionally complete linear ordered field.
* `unique.order_ring_iso` : Uniqueness of `order_ring_iso`s between two
  conditionally complete linearly ordered fields.

## References

* https://mathoverflow.net/questions/362991/
  who-first-characterized-the-real-numbers-as-the-unique-complete-ordered-field

## Tags

reals, conditionally complete, ordered field, uniqueness
-/

variable {F α β γ : Type _}

noncomputable section

open Function Rat Real Set

open Classical Pointwise

/- ./././Mathport/Syntax/Translate/Command.lean:417:11: unsupported: advanced extends in structure -/
/-- A field which is both linearly ordered and conditionally complete with respect to the order.
This axiomatizes the reals. -/
@[protect_proj]
class ConditionallyCompleteLinearOrderedField (α : Type _) extends
  "./././Mathport/Syntax/Translate/Command.lean:417:11: unsupported: advanced extends in structure",
  ConditionallyCompleteLinearOrder α
#align conditionally_complete_linear_ordered_field ConditionallyCompleteLinearOrderedField

-- see Note [lower instance priority]
/-- Any conditionally complete linearly ordered field is archimedean. -/
instance (priority := 100) ConditionallyCompleteLinearOrderedField.to_archimedean
    [ConditionallyCompleteLinearOrderedField α] : Archimedean α :=
  archimedean_iff_nat_lt.2
    (by
      by_contra' h
      obtain ⟨x, h⟩ := h
      have :=
        csupₛ_le (range_nonempty (coe : ℕ → α))
          (forall_range_iff.2 fun n =>
            le_sub_iff_add_le.2 <| le_csupₛ ⟨x, forall_range_iff.2 h⟩ ⟨n + 1, Nat.cast_succ n⟩)
      linarith)
#align conditionally_complete_linear_ordered_field.to_archimedean ConditionallyCompleteLinearOrderedField.to_archimedean

/-- The reals are a conditionally complete linearly ordered field. -/
instance : ConditionallyCompleteLinearOrderedField ℝ :=
  { Real.linearOrderedField, Real.conditionallyCompleteLinearOrder with }

namespace LinearOrderedField

/-!
### Rational cut map

The idea is that a conditionally complete linear ordered field is fully characterized by its copy of
the rationals. Hence we define `rat.cut_map β : α → set β` which sends `a : α` to the "rationals in
`β`" that are less than `a`.
-/

section CutMap

variable [LinearOrderedField α]

section DivisionRing

variable (β) [DivisionRing β] {a a₁ a₂ : α} {b : β} {q : ℚ}

/-- The lower cut of rationals inside a linear ordered field that are less than a given element of
another linear ordered field. -/
def cutMap (a : α) : Set β :=
  (coe : ℚ → β) '' { t | ↑t < a }
#align linear_ordered_field.cut_map LinearOrderedField.cutMap

theorem cutMap_mono (h : a₁ ≤ a₂) : cutMap β a₁ ⊆ cutMap β a₂ :=
  image_subset _ fun _ => h.trans_lt'
#align linear_ordered_field.cut_map_mono LinearOrderedField.cutMap_mono

variable {β}

@[simp]
theorem mem_cutMap_iff : b ∈ cutMap β a ↔ ∃ q : ℚ, (q : α) < a ∧ (q : β) = b :=
  Iff.rfl
#align linear_ordered_field.mem_cut_map_iff LinearOrderedField.mem_cutMap_iff

@[simp]
theorem coe_mem_cutMap_iff [CharZero β] : (q : β) ∈ cutMap β a ↔ (q : α) < a :=
  Rat.cast_injective.mem_set_image
#align linear_ordered_field.coe_mem_cut_map_iff LinearOrderedField.coe_mem_cutMap_iff

theorem cutMap_self (a : α) : cutMap α a = Iio a ∩ range (coe : ℚ → α) :=
  by
  ext
  constructor
  · rintro ⟨q, h, rfl⟩
    exact ⟨h, q, rfl⟩
  · rintro ⟨h, q, rfl⟩
    exact ⟨q, h, rfl⟩
#align linear_ordered_field.cut_map_self LinearOrderedField.cutMap_self

end DivisionRing

variable (β) [LinearOrderedField β] {a a₁ a₂ : α} {b : β} {q : ℚ}

theorem cutMap_coe (q : ℚ) : cutMap β (q : α) = coe '' { r : ℚ | (r : β) < q } := by
  simp_rw [cut_map, Rat.cast_lt]
#align linear_ordered_field.cut_map_coe LinearOrderedField.cutMap_coe

variable [Archimedean α]

theorem cutMap_nonempty (a : α) : (cutMap β a).Nonempty :=
  Nonempty.image _ <| exists_rat_lt a
#align linear_ordered_field.cut_map_nonempty LinearOrderedField.cutMap_nonempty

theorem cutMap_bddAbove (a : α) : BddAbove (cutMap β a) :=
  by
  obtain ⟨q, hq⟩ := exists_rat_gt a
  exact ⟨q, ball_image_iff.2 fun r hr => by exact_mod_cast (hq.trans' hr).le⟩
#align linear_ordered_field.cut_map_bdd_above LinearOrderedField.cutMap_bddAbove

theorem cutMap_add (a b : α) : cutMap β (a + b) = cutMap β a + cutMap β b :=
  by
  refine' (image_subset_iff.2 fun q hq => _).antisymm _
  · rw [mem_set_of_eq, ← sub_lt_iff_lt_add] at hq
    obtain ⟨q₁, hq₁q, hq₁ab⟩ := exists_rat_btwn hq
    refine' ⟨q₁, q - q₁, _, _, add_sub_cancel'_right _ _⟩ <;> try norm_cast <;>
      rwa [coe_mem_cut_map_iff]
    exact_mod_cast sub_lt_comm.mp hq₁q
  · rintro _ ⟨_, _, ⟨qa, ha, rfl⟩, ⟨qb, hb, rfl⟩, rfl⟩
    refine' ⟨qa + qb, _, by norm_cast⟩
    rw [mem_set_of_eq, cast_add]
    exact add_lt_add ha hb
#align linear_ordered_field.cut_map_add LinearOrderedField.cutMap_add

end CutMap

/-!
### Induced map

`rat.cut_map` spits out a `set β`. To get something in `β`, we now take the supremum.
-/

section [anonymous]

variable (α β γ) [LinearOrderedField α] [ConditionallyCompleteLinearOrderedField β]
  [ConditionallyCompleteLinearOrderedField γ]

/-- The induced order preserving function from a linear ordered field to a conditionally complete
linear ordered field, defined by taking the Sup in the codomain of all the rationals less than the
input. -/
def inducedMap (x : α) : β :=
  supₛ <| cutMap β x
#align linear_ordered_field.induced_map LinearOrderedField.inducedMap

variable [Archimedean α]

theorem inducedMap_mono : Monotone (inducedMap α β) := fun a b h =>
  csupₛ_le_csupₛ (cutMap_bddAbove β _) (cutMap_nonempty β _) (cutMap_mono β h)
#align linear_ordered_field.induced_map_mono LinearOrderedField.inducedMap_mono

theorem inducedMap_rat (q : ℚ) : inducedMap α β (q : α) = q :=
  by
  refine'
    csupₛ_eq_of_forall_le_of_forall_lt_exists_gt (cut_map_nonempty β q) (fun x h => _) fun w h => _
  · rw [cut_map_coe] at h
    obtain ⟨r, h, rfl⟩ := h
    exact le_of_lt h
  · obtain ⟨q', hwq, hq⟩ := exists_rat_btwn h
    rw [cut_map_coe]
    exact ⟨q', ⟨_, hq, rfl⟩, hwq⟩
#align linear_ordered_field.induced_map_rat LinearOrderedField.inducedMap_rat

@[simp]
theorem inducedMap_zero : inducedMap α β 0 = 0 := by exact_mod_cast induced_map_rat α β 0
#align linear_ordered_field.induced_map_zero LinearOrderedField.inducedMap_zero

@[simp]
theorem inducedMap_one : inducedMap α β 1 = 1 := by exact_mod_cast induced_map_rat α β 1
#align linear_ordered_field.induced_map_one LinearOrderedField.inducedMap_one

variable {α β} {a : α} {b : β} {q : ℚ}

theorem inducedMap_nonneg (ha : 0 ≤ a) : 0 ≤ inducedMap α β a :=
  (inducedMap_zero α _).ge.trans <| inducedMap_mono _ _ ha
#align linear_ordered_field.induced_map_nonneg LinearOrderedField.inducedMap_nonneg

theorem coe_lt_inducedMap_iff : (q : β) < inducedMap α β a ↔ (q : α) < a :=
  by
  refine' ⟨fun h => _, fun hq => _⟩
  · rw [← induced_map_rat α] at h
    exact (induced_map_mono α β).reflect_lt h
  · obtain ⟨q', hq, hqa⟩ := exists_rat_btwn hq
    apply lt_csupₛ_of_lt (cut_map_bdd_above β a) (coe_mem_cut_map_iff.mpr hqa)
    exact_mod_cast hq
#align linear_ordered_field.coe_lt_induced_map_iff LinearOrderedField.coe_lt_inducedMap_iff

theorem lt_inducedMap_iff : b < inducedMap α β a ↔ ∃ q : ℚ, b < q ∧ (q : α) < a :=
  ⟨fun h => (exists_rat_btwn h).imp fun q => And.imp_right coe_lt_inducedMap_iff.1,
    fun ⟨q, hbq, hqa⟩ => hbq.trans <| by rwa [coe_lt_induced_map_iff]⟩
#align linear_ordered_field.lt_induced_map_iff LinearOrderedField.lt_inducedMap_iff

@[simp]
theorem inducedMap_self (b : β) : inducedMap β β b = b :=
  eq_of_forall_rat_lt_iff_lt fun q => coe_lt_inducedMap_iff
#align linear_ordered_field.induced_map_self LinearOrderedField.inducedMap_self

variable (α β)

@[simp]
theorem inducedMap_inducedMap (a : α) : inducedMap β γ (inducedMap α β a) = inducedMap α γ a :=
  eq_of_forall_rat_lt_iff_lt fun q => by
    rw [coe_lt_induced_map_iff, coe_lt_induced_map_iff, Iff.comm, coe_lt_induced_map_iff]
#align linear_ordered_field.induced_map_induced_map LinearOrderedField.inducedMap_inducedMap

@[simp]
theorem inducedMap_inv_self (b : β) : inducedMap γ β (inducedMap β γ b) = b := by
  rw [induced_map_induced_map, induced_map_self]
#align linear_ordered_field.induced_map_inv_self LinearOrderedField.inducedMap_inv_self

theorem inducedMap_add (x y : α) : inducedMap α β (x + y) = inducedMap α β x + inducedMap α β y :=
  by
  rw [[anonymous], cut_map_add]
  exact
    csupₛ_add (cut_map_nonempty β x) (cut_map_bdd_above β x) (cut_map_nonempty β y)
      (cut_map_bdd_above β y)
#align linear_ordered_field.induced_map_add LinearOrderedField.inducedMap_add

variable {α β}

/-- Preparatory lemma for `induced_ring_hom`. -/
theorem le_inducedMap_mul_self_of_mem_cutMap (ha : 0 < a) (b : β) (hb : b ∈ cutMap β (a * a)) :
    b ≤ inducedMap α β a * inducedMap α β a :=
  by
  obtain ⟨q, hb, rfl⟩ := hb
  obtain ⟨q', hq', hqq', hqa⟩ := exists_rat_pow_btwn two_ne_zero hb (mul_self_pos.2 ha.ne')
  trans (q' : β) ^ 2
  exact_mod_cast hqq'.le
  rw [pow_two] at hqa⊢
  exact
    mul_self_le_mul_self (by exact_mod_cast hq'.le)
      (le_csupₛ (cut_map_bdd_above β a) <|
        coe_mem_cut_map_iff.2 <| lt_of_mul_self_lt_mul_self ha.le hqa)
#align linear_ordered_field.le_induced_map_mul_self_of_mem_cut_map LinearOrderedField.le_inducedMap_mul_self_of_mem_cutMap

/-- Preparatory lemma for `induced_ring_hom`. -/
theorem exists_mem_cutMap_mul_self_of_lt_inducedMap_mul_self (ha : 0 < a) (b : β)
    (hba : b < inducedMap α β a * inducedMap α β a) : ∃ c ∈ cutMap β (a * a), b < c :=
  by
  obtain hb | hb := lt_or_le b 0
  · refine' ⟨0, _, hb⟩
    rw [← Rat.cast_zero, coe_mem_cut_map_iff, Rat.cast_zero]
    exact mul_self_pos.2 ha.ne'
  obtain ⟨q, hq, hbq, hqa⟩ := exists_rat_pow_btwn two_ne_zero hba (hb.trans_lt hba)
  rw [← cast_pow] at hbq
  refine' ⟨(q ^ 2 : ℚ), coe_mem_cut_map_iff.2 _, hbq⟩
  rw [pow_two] at hqa⊢
  push_cast
  obtain ⟨q', hq', hqa'⟩ := lt_induced_map_iff.1 (lt_of_mul_self_lt_mul_self _ hqa)
  exact mul_self_lt_mul_self (by exact_mod_cast hq.le) (hqa'.trans' <| by assumption_mod_cast)
  exact induced_map_nonneg ha.le
#align linear_ordered_field.exists_mem_cut_map_mul_self_of_lt_induced_map_mul_self LinearOrderedField.exists_mem_cutMap_mul_self_of_lt_inducedMap_mul_self

variable (α β)

/-- `induced_map` as an additive homomorphism. -/
def inducedAddHom : α →+ β :=
  ⟨inducedMap α β, inducedMap_zero α β, inducedMap_add α β⟩
#align linear_ordered_field.induced_add_hom LinearOrderedField.inducedAddHom

/-- `induced_map` as an `order_ring_hom`. -/
@[simps]
def inducedOrderRingHom : α →+*o β :=
  {
    (inducedAddHom α β).mkRingHomOfMulSelfOfTwoNeZero
      (-- reduce to the case of x = y
      by
        -- reduce to the case of 0 < x
        suffices
          ∀ x, 0 < x → induced_add_hom α β (x * x) = induced_add_hom α β x * induced_add_hom α β x
          by
          rintro x
          obtain h | rfl | h := lt_trichotomy x 0
          · convert this (-x) (neg_pos.2 h) using 1
            · rw [neg_mul, mul_neg, neg_neg]
            · simp_rw [AddMonoidHom.map_neg, neg_mul, mul_neg, neg_neg]
          · simp only [MulZeroClass.mul_zero, AddMonoidHom.map_zero]
          · exact this x h
        -- prove that the (Sup of rationals less than x) ^ 2 is the Sup of the set of rationals less
        -- than (x ^ 2) by showing it is an upper bound and any smaller number is not an upper bound
        refine' fun x hx => csupₛ_eq_of_forall_le_of_forall_lt_exists_gt (cut_map_nonempty β _) _ _
        exact le_induced_map_mul_self_of_mem_cut_map hx
        exact exists_mem_cut_map_mul_self_of_lt_induced_map_mul_self hx)
      two_ne_zero (inducedMap_one _ _) with
    monotone' := inducedMap_mono _ _ }
#align linear_ordered_field.induced_order_ring_hom LinearOrderedField.inducedOrderRingHom

/-- The isomorphism of ordered rings between two conditionally complete linearly ordered fields. -/
def inducedOrderRingIso : β ≃+*o γ :=
  { inducedOrderRingHom β γ with
    invFun := inducedMap γ β
    left_inv := inducedMap_inv_self _ _
    right_inv := inducedMap_inv_self _ _
    map_le_map_iff' := fun x y =>
      by
      refine' ⟨fun h => _, fun h => induced_map_mono _ _ h⟩
      simpa [induced_order_ring_hom, AddMonoidHom.mkRingHomOfMulSelfOfTwoNeZero,
        induced_add_hom] using induced_map_mono γ β h }
#align linear_ordered_field.induced_order_ring_iso LinearOrderedField.inducedOrderRingIso

@[simp]
theorem coe_inducedOrderRingIso : ⇑(inducedOrderRingIso β γ) = inducedMap β γ :=
  rfl
#align linear_ordered_field.coe_induced_order_ring_iso LinearOrderedField.coe_inducedOrderRingIso

@[simp]
theorem inducedOrderRingIso_symm : (inducedOrderRingIso β γ).symm = inducedOrderRingIso γ β :=
  rfl
#align linear_ordered_field.induced_order_ring_iso_symm LinearOrderedField.inducedOrderRingIso_symm

@[simp]
theorem inducedOrderRingIso_self : inducedOrderRingIso β β = OrderRingIso.refl β :=
  OrderRingIso.ext inducedMap_self
#align linear_ordered_field.induced_order_ring_iso_self LinearOrderedField.inducedOrderRingIso_self

open OrderRingIso

/-- There is a unique ordered ring homomorphism from an archimedean linear ordered field to a
conditionally complete linear ordered field. -/
instance : Unique (α →+*o β) :=
  uniqueOfSubsingleton <| inducedOrderRingHom α β

/-- There is a unique ordered ring isomorphism between two conditionally complete linear ordered
fields. -/
instance : Unique (β ≃+*o γ) :=
  uniqueOfSubsingleton <| inducedOrderRingIso β γ

end [anonymous]

end LinearOrderedField

section Real

variable {R S : Type _} [OrderedRing R] [LinearOrderedRing S]

theorem ringHom_monotone (hR : ∀ r : R, 0 ≤ r → ∃ s : R, s ^ 2 = r) (f : R →+* S) : Monotone f :=
  (monotone_iff_map_nonneg f).2 fun r h =>
    by
    obtain ⟨s, rfl⟩ := hR r h
    rw [map_pow]
    apply sq_nonneg
#align ring_hom_monotone ringHom_monotone

/-- There exists no nontrivial ring homomorphism `ℝ →+* ℝ`. -/
instance Real.RingHom.unique : Unique (ℝ →+* ℝ)
    where
  default := RingHom.id ℝ
  uniq f :=
    congr_arg OrderRingHom.toRingHom
      (Subsingleton.elim ⟨f, ringHom_monotone (fun r hr => ⟨Real.sqrt r, sq_sqrt hr⟩) f⟩ default)
#align real.ring_hom.unique Real.RingHom.unique

end Real


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.simulate.basic

/-!
# Distributions of Simulations

This file contains more complicated lemmas for `eval_dist` applied to `simulate` and `simulate'`.
-/

variables {α β γ : Type} {spec spec' spec'' : oracle_spec} {S S' : Type}

namespace oracle_comp

open oracle_spec
open_locale nnreal ennreal

variables (so : sim_oracle spec spec' S) (so' : sim_oracle spec spec'' S')
  (a : α) (i : spec.ι) (t : spec.domain i) (oa oa' : oracle_comp spec α)
  (ob ob' : α → oracle_comp spec β) (s : S) (f : α → β)

section monad

lemma eval_dist_simulate_map_bind (g : β → γ) : ⁅simulate so (g <$> (oa >>= ob)) s⁆ =
  ⁅simulate so oa s⁆.bind (λ x, ⁅simulate so (ob x.1) x.2⁆.map (prod.map g id)) :=
by simp only [simulate_map, simulate_bind, eval_dist_map, eval_dist_bind, pmf.map_bind]

lemma eval_dist_simulate_map_bind' (g : β → γ) : ⁅simulate so (g <$> (oa >>= ob)) s⁆ =
  ⁅simulate so oa s⁆.bind (λ x, ⁅prod.map g id <$> simulate so (ob x.1) x.2⁆) :=
by simp only [simulate_map, simulate_bind, eval_dist_map, eval_dist_bind, pmf.map_bind]

lemma eval_dist_simulate_map_bind_apply [decidable_eq γ] [decidable_eq S]
  (g : β → γ) (z : γ × S) : ⁅simulate so (g <$> (oa >>= ob)) s⁆ z =
    ∑' (x : α × S), ⁅simulate so oa s⁆ x * ∑' (y : β),
      ite (z.1 = g y) (⁅simulate so (ob x.1) x.2⁆ (y, z.2)) 0 :=
by simp only [eval_dist_simulate_map_bind', pmf.bind_apply, eval_dist_map_prod_map_id_right_apply]

end monad

/-- Lemma for inductively proving the support of a simulation is a specific function of the input.
Often this is simpler than induction on the computation itself, especially the case of `bind` -/
lemma eval_dist_simulate_eq_induction {pr : Π (α : Type), oracle_comp spec α → S → (pmf (α × S))}
  (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) (s : S)
  (h_ret : ∀ α a s, pr α (return a) s = pmf.pure (a, s))
  (h_bind : ∀ α β (oa : oracle_comp spec α) (ob : α → oracle_comp spec β) s,
    pr β (oa >>= ob) s = (pr α oa s).bind (λ x, pr β (ob x.1) x.2))
  (h_query : ∀ i t s, pr (spec.range i) (query i t) s = ⁅so i (t, s)⁆) :
  ⁅simulate so oa s⁆ = pr α oa s :=
begin
  induction oa using oracle_comp.induction_on with α a' α β oa ob hoa hob i t generalizing s,
  { simp only [h_ret, simulate_return, eval_dist_return] },
  { simp only [h_bind, hoa, hob, simulate_bind, eval_dist_bind] },
  { simp only [h_query, simulate_query] }
end

/-- Lemma for inductively proving that the distribution associated to a simulation
is a specific function. Gives more explicit criteria than induction on the computation.
In particular this automatically splits the cases for `return` and the `prod` in the `bind` sum. -/
lemma eval_dist_simulate_apply_eq_induction
  {pr : Π (α : Type), oracle_comp spec α → S → α × S → ℝ≥0∞}
  (so : sim_oracle spec spec' S) (oa : oracle_comp spec α) (s : S) (a : α) (s' : S)
  (h_ret : ∀ α a s, pr α (return a) s (a, s) = 1)
  (h_ret' : ∀ α a a' s s', a ≠ a' ∨ s ≠ s' → pr α (return a) s (a', s') = 0)
  (h_bind : ∀ α β (oa : oracle_comp spec α) (ob : α → oracle_comp spec β) s b s',
    pr β (oa >>= ob) s (b, s') = ∑' (a : α) (t : S), (pr α oa s (a, t)) * (pr β (ob a) t (b, s')))
  (h_query : ∀ i t s u s', pr (spec.range i) (query i t) s (u, s') = ⁅so i (t, s)⁆ (u, s')) :
  ⁅simulate so oa s⁆ (a, s') = pr α oa s (a, s') :=
begin
  induction oa using oracle_comp.induction_on with α a' α β oa ob hoa hob i t generalizing s s',
  { rw [eval_dist_simulate_return, pmf.pure_apply],
    split_ifs with has,
    { simp only [prod.eq_iff_fst_eq_snd_eq] at has,
      refine has.1 ▸ has.2.symm ▸ (h_ret α a s).symm, },
    { simp only [prod.eq_iff_fst_eq_snd_eq, not_and_distrib] at has,
      cases has with ha hs,
      { exact (h_ret' α a' a s s' $ or.inl $ ne.symm ha).symm },
      { exact (h_ret' α a' a s s' $ or.inr $ ne.symm hs).symm } } },
  { simp only [eval_dist_simulate_bind_apply_eq_tsum_tsum, h_bind, hoa, hob] },
  { rw [eval_dist_simulate_query, h_query] },
end

/-- If the main output of oracle queries is uniformly distributed (ignoring the oracle state),
then the output distribution under `simulate'` is exactly the original distribution,
since we define `eval_dist` to be uniform on oracle calls. -/
theorem eval_dist_simulate'_eq_eval_dist
  (h : ∀ i t s, ⁅so i (t, s)⁆.map prod.fst = pmf.uniform_of_fintype (spec.range i)) :
  ⁅simulate' so oa s⁆ = ⁅oa⁆ :=
begin
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s,
  { simp only [simulate'_return, eval_dist_map_return, eval_dist_return] },
  { refine pmf.ext (λ b, _),
    rw [eval_dist_bind_apply_eq_tsum, eval_dist_simulate'_bind_apply],
    refine tsum_congr (λ a, _),
    rw [← hoa s, eval_dist_simulate'_apply, ← ennreal.tsum_mul_right],
    refine tsum_congr (λ t, _),
    rw ← hob },
  { simp only [h, simulate'_query, eval_dist_map, eval_dist_query] }
end

/-- Given two simulation oracles `so` and `so'`, if the output distribution of oracle queries
(ignoring the output state) is the same for any input and pair of initial oracle states,
then the output distribution of simulating a computation is the same for both. -/
theorem eval_dist_simulate'_eq_eval_dist_simulate'
  {so : sim_oracle spec spec' S} {so' : sim_oracle spec spec'' S'}
  (h : ∀ i t s s', ⁅so i (t, s)⁆.map prod.fst = ⁅so' i (t, s')⁆.map prod.fst)
  (oa : oracle_comp spec α) (s : S) (s' : S') :
  ⁅simulate' so oa s⁆ = ⁅simulate' so' oa s'⁆ :=
begin
  induction oa using oracle_comp.induction_on with α a α β oa ob hoa hob i t generalizing s s',
  { simp only [simulate'_return, eval_dist_map_return] },
  { refine pmf.ext (λ b, _),
    simp only [eval_dist_simulate'_bind_apply],
    refine tsum_congr (λ a, _),
    calc ∑' (t : S), ⁅simulate so oa s⁆ (a, t) * ⁅simulate' so (ob a) t⁆ b
      = ∑' (t : S), ⁅simulate so oa s⁆ (a, t) * ⁅simulate' so' (ob a) s'⁆ b :
        tsum_congr (λ t, congr_arg (λ x, _ * x) $ by rw hob a t s')
      ... = (∑' (t' : S'), ⁅simulate so' oa s'⁆ (a, t')) * ⁅simulate' so' (ob a) s'⁆ b :
        by simp_rw [ennreal.tsum_mul_right, ← eval_dist_simulate'_apply, hoa s s']
      ... = ∑' (t' : S'), ⁅simulate so' oa s'⁆ (a, t') * ⁅simulate' so (ob a) s⁆ b :
        by rw [ennreal.tsum_mul_right, hob]
      ... = ∑' (t' : S'), ⁅simulate so' oa s'⁆ (a, t') * ⁅simulate' so' (ob a) t'⁆ b :
        tsum_congr (λ t, congr_arg (λ x, _ * x) $ by rw hob) },
  { simpa only [simulate'_query, eval_dist_map] using h i t s s' },
end

end oracle_comp


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Init.LawfulLT

namespace Sigma

universe u v

-- Relation on the first component
def relOnFst {α₁ α₂ : Type _} {β₁ : α₁ → Type _} {β₂ : α₂ → Type _} (r : α₁ → α₂ → Prop) : Sigma β₁ → Sigma β₂ → Prop :=
  λ x y => r x.fst y.fst

instance instTransOfFst {α₁ α₂ α₃ : Type _} {β₁ : α₁ → Type _} {β₂ : α₂ → Type _} {β₃ : α₃ → Type _} {r₁ : α₁ → α₂ → Prop} {r₂ : α₂ → α₃ → Prop} {r : α₁ → α₃ → Prop} [Trans r₁ r₂ r] : Trans (Sigma.relOnFst (β₁:=β₁) (β₂:=β₂) r₁) (Sigma.relOnFst (β₁:=β₂) (β₂:=β₃) r₂) (Sigma.relOnFst r) where
  trans := by dsimp [relOnFst]; exact trans

section Eq

variable {α : Type u} {β : α → Type v}

--- Decidability of the equality of Sigma type
instance instDecidableEqSigma [DecidableEq α] [(a : α) → DecidableEq (β a)] : DecidableEq (Sigma β) :=
  λ x y =>
    if h : x.1=y.1 then
      if h₂ : (h▸x.2) = y.2 then
        isTrue $ by
          cases x with | mk a x =>
          cases y with | mk b y =>
          dsimp at h; cases h
          dsimp at h₂; cases h₂
          rfl
      else
        isFalse $ by
          cases x with | mk a x =>
          cases y with | mk b y =>
          dsimp at h; cases h
          dsimp at *
          intro heq; cases heq
          exact absurd rfl h₂
    else
      Decidable.isFalse (λ heq => absurd (congrArg Sigma.fst heq) h)

protected
theorem eq_of_eq_snd {a : α} {b₁ b₂ : β a} : b₁ = b₂ → Sigma.mk a b₁ = Sigma.mk a b₂ :=
  λ h => h ▸ rfl

end Eq

protected
inductive lex {α : Type u} {β : α → Type v} (r : α → α → Prop) (s : (a : α) → β a → β a → Prop) : Sigma β → Sigma β → Prop
| fst {a b : α} {x : β a} {y : β b} : r a b → Sigma.lex r s ⟨a,x⟩ ⟨b,y⟩
| snd {a : α} {x y : β a} : s a x y → Sigma.lex r s ⟨a,x⟩ ⟨a,y⟩

namespace lex

variable {α : Type u} {β : α → Type v} {r : α → α → Prop} {s : (a : α) → β a → β a → Prop}

instance instDecidableRellex [DecidableEq α] [DecidableRel r] [(a : α) → DecidableRel (s a)] : DecidableRel (Sigma.lex r s)
| mk a₁ b₁, mk a₂ b₂ =>
  if hfst : r a₁ a₂ then
    isTrue $ lex.fst hfst
  else if heq : a₁ = a₂ then
    if hsnd : s a₁ b₁ (heq ▸ b₂) then
      isTrue $ heq ▸ lex.snd hsnd
    else
      isFalse $ by
        cases heq; dsimp at *
        intro h; cases h <;> contradiction
  else
    isFalse $ by
      intro hcontra; cases hcontra <;> contradiction

instance instTranslex [Trans r r r] [(a : α) → Trans (s a) (s a) (s a)] : Trans (Sigma.lex r s) (Sigma.lex r s) (Sigma.lex r s) where
  trans
  | fst hab, fst hbc => lex.fst (trans hab hbc)
  | fst hab, snd _ => lex.fst hab
  | snd _, fst hbc => lex.fst hbc
  | snd hab, snd hbc => lex.snd (trans hab hbc)

instance instIrreflectivelex [Irreflective r] [(a : α) → Irreflective (s a)] : Irreflective (Sigma.lex r s) where
  irrefl
  | mk a _, fst h => absurd h (Irreflective.irrefl a)
  | mk _ b, snd h => absurd h (Irreflective.irrefl b)

instance instAsymmetrylex [Asymmetry r] [(a : α) → Asymmetry (s a)] : Asymmetry (Sigma.lex r s) where
  asymm _ _
  | fst hab, fst hba => Asymmetry.asymm _ _ hab hba
  | fst hab, snd _ => Asymmetry.asymm _ _ hab hab
  | snd _, fst hba => Asymmetry.asymm _ _ hba hba
  | snd hab, snd hba => Asymmetry.asymm _ _ hab hba

instance instTrichotomouslex [Trichotomous r] [(a : α) → Trichotomous (s a)] : Trichotomous (Sigma.lex r s) where
  trichot
  | mk a₁ b₁, mk a₂ b₂ =>
    trichotCasesOn r (motive:=λ a₁ a₂=> ∀ (b₁ : β a₁) (b₂ : β a₂), Sigma.mk a₁ b₁ = Sigma.mk a₂ b₂ ∨ Sigma.lex r s ⟨a₁,b₁⟩ ⟨a₂,b₂⟩ ∨ Sigma.lex r s ⟨a₂,b₂⟩ ⟨a₁,b₁⟩) a₁ a₂
      (λ a b₁ b₂ =>
        trichotCasesOn (s a) b₁ b₂
          (λ _ => Or.inl rfl)
          (λ _ _ h => Or.inr $ Or.inl $ lex.snd h)
          (λ _ _ h => Or.inr $ Or.inr $ lex.snd h)
      )
      (λ _ _ h _ _ => Or.inr $ Or.inl $ lex.fst h)
      (λ _ _ h _ _ => Or.inr $ Or.inr $ lex.fst h)
      b₁ b₂

end lex

-- The relation `LT`
section LT

variable {α : Type u} {β : α → Type v}

--- Lexicographical ordering on the Sigma type
protected
inductive lt [LT α] [(a : α) → LT (β a)] : Sigma β → Sigma β → Prop
| fst {a b : α} {x : β a} {y : β b} : a < b → Sigma.lt ⟨a,x⟩ ⟨b,y⟩
| snd {a : α} {x y : β a} : x < y → Sigma.lt ⟨a,x⟩ ⟨a,y⟩

instance instLTSigma [LT α] [(a : α) → LT (β a)] : LT (Sigma β) where
  lt := Sigma.lt

instance sigmaHasDecidableLT [DecidableEq α] [LT α] [DecidableRel (α:=α) LT.lt] [(a : α) → LT (β a)] [(a : α) → DecidableRel (α:=β a) LT.lt] : DecidableRel (α:=Sigma β) LT.lt
| mk a₁ b₁, mk a₂ b₂ =>
  if ha : a₁ < a₂ then
    isTrue $ Sigma.lt.fst ha
  else if heq : a₁ = a₂ then
      if hb : b₁ < heq ▸ b₂ then
        isTrue $ heq ▸ Sigma.lt.snd hb
      else
        isFalse $ by
          cases heq; dsimp at *
          intro hlt; cases hlt <;> contradiction
  else
    isFalse $ by
      intro hlt; cases hlt <;> contradiction

instance instLawfulLTSigma [LawfulLT α] [(a : α) → LawfulLT (β a)] : LawfulLT (Sigma β) where
  irrefl x := by
    cases x
    intro hlt; cases hlt <;> exact absurd ‹_<_› (Irreflective.irrefl _)
  trans := by
    intro x y z hxy hyz
    cases x with | mk xa xb =>
    cases y with | mk ya yb =>
    cases z with | mk za zb =>
    cases hxy <;> cases hyz
    . exact Sigma.lt.fst (trans ‹xa < ya› ‹ya < za›)
    . exact Sigma.lt.fst ‹xa < ya›
    . exact Sigma.lt.fst ‹xa < za›
    . apply Sigma.lt.snd; exact (trans ‹xb < _› ‹_ < _›)

instance instLinearLTSigma [LinearLT α] [(a : α) → LinearLT (β a)] : LinearLT (Sigma β) where
  trichot x y := by
    cases x with | mk xa xb =>
    cases y with | mk ya yb =>
    apply trichotCasesOn (motive:=λ xa ya => ∀ (xb : β xa) (yb : β ya), Sigma.mk xa xb = ⟨ya,yb⟩ ∨ Sigma.mk xa xb < Sigma.mk ya yb ∨ Sigma.mk xa xb > ⟨ya,yb⟩) LT.lt xa ya _ _ _ xb yb
    . intro a xb yb
      apply Or.map Sigma.eq_of_eq_snd (Or.map Sigma.lt.snd Sigma.lt.snd)
      exact Trichotomous.trichot (α:=β a) (r:=LT.lt) xb yb
    . intro xa ya hxaya xb yb
      apply Or.inr $ Or.inl $ Sigma.lt.fst hxaya
    . intro xa ya hyaxa xb yb
      apply Or.inr $ Or.inr $ Sigma.lt.fst hyaxa

end LT

end Sigma