/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jeremy Avigad, Simon Hudon
-/
import data.set.basic
import logic.equiv.basic

/-!
# Partial values of a type

This file defines `part α`, the partial values of a type.

`o : part α` carries a proposition `o.dom`, its domain, along with a function `get : o.dom → α`, its
value. The rule is then that every partial value has a value but, to access it, you need to provide
a proof of the domain.

`part α` behaves the same as `option α` except that `o : option α` is decidably `none` or `some a`
for some `a : α`, while the domain of `o : part α` doesn't have to be decidable. That means you can
translate back and forth between a partial value with a decidable domain and an option, and
`option α` and `part α` are classically equivalent. In general, `part α` is bigger than `option α`.

In current mathlib, `part ℕ`, aka `enat`, is used to move decidability of the order to decidability
of `enat.find` (which is the smallest natural satisfying a predicate, or `∞` if there's none).

## Main declarations

`option`-like declarations:
* `part.none`: The partial value whose domain is `false`.
* `part.some a`: The partial value whose domain is `true` and whose value is `a`.
* `part.of_option`: Converts an `option α` to a `part α` by sending `none` to `none` and `some a` to
  `some a`.
* `part.to_option`: Converts a `part α` with a decidable domain to an `option α`.
* `part.equiv_option`: Classical equivalence between `part α` and `option α`.

Monadic structure:
* `part.bind`: `o.bind f` has value `(f (o.get _)).get _` (`f o` morally) and is defined when `o`
  and `f (o.get _)` are defined.
* `part.map`: Maps the value and keeps the same domain.

Other:
* `part.restrict`: `part.restrict p o` replaces the domain of `o : part α` by `p : Prop` so long as
  `p → o.dom`.
* `part.assert`: `assert p f` appends `p` to the domains of the values of a partial function.
* `part.unwrap`: Gets the value of a partial value regardless of its domain. Unsound.

## Notation

For `a : α`, `o : part α`, `a ∈ o` means that `o` is defined and equal to `a`. Formally, it means
`o.dom` and `o.get _ = a`.
-/

open function

/-- `part α` is the type of "partial values" of type `α`. It
  is similar to `option α` except the domain condition can be an
  arbitrary proposition, not necessarily decidable. -/
structure {u} part (α : Type u) : Type u :=
(dom : Prop)
(get : dom → α)

namespace part
variables {α : Type*} {β : Type*} {γ : Type*}

/-- Convert a `part α` with a decidable domain to an option -/
def to_option (o : part α) [decidable o.dom] : option α :=
if h : dom o then some (o.get h) else none

/-- `part` extensionality -/
theorem ext' : ∀ {o p : part α}
  (H1 : o.dom ↔ p.dom)
  (H2 : ∀h₁ h₂, o.get h₁ = p.get h₂), o = p
| ⟨od, o⟩ ⟨pd, p⟩ H1 H2 := have t : od = pd, from propext H1,
  by cases t; rw [show o = p, from funext $ λp, H2 p p]

/-- `part` eta expansion -/
@[simp] theorem eta : Π (o : part α), (⟨o.dom, λ h, o.get h⟩ : part α) = o
| ⟨h, f⟩ := rfl

/-- `a ∈ o` means that `o` is defined and equal to `a` -/
protected def mem (a : α) (o : part α) : Prop := ∃ h, o.get h = a

instance : has_mem α (part α) := ⟨part.mem⟩

theorem mem_eq (a : α) (o : part α) : (a ∈ o) = (∃ h, o.get h = a) :=
rfl

theorem dom_iff_mem : ∀ {o : part α}, o.dom ↔ ∃ y, y ∈ o
| ⟨p, f⟩ := ⟨λh, ⟨f h, h, rfl⟩, λ⟨_, h, rfl⟩, h⟩

theorem get_mem {o : part α} (h) : get o h ∈ o := ⟨_, rfl⟩

@[simp] lemma mem_mk_iff {p : Prop} {o : p → α} {a : α} : a ∈ part.mk p o ↔ ∃ h, o h = a := iff.rfl

/-- `part` extensionality -/
@[ext]
theorem ext {o p : part α} (H : ∀ a, a ∈ o ↔ a ∈ p) : o = p :=
ext' ⟨λ h, ((H _).1 ⟨h, rfl⟩).fst,
     λ h, ((H _).2 ⟨h, rfl⟩).fst⟩ $
λ a b, ((H _).2 ⟨_, rfl⟩).snd

/-- The `none` value in `part` has a `false` domain and an empty function. -/
def none : part α := ⟨false, false.rec _⟩

instance : inhabited (part α) := ⟨none⟩

@[simp] theorem not_mem_none (a : α) : a ∉ @none α := λ h, h.fst

/-- The `some a` value in `part` has a `true` domain and the
  function returns `a`. -/
def some (a : α) : part α := ⟨true, λ_, a⟩

theorem mem_unique : ∀ {a b : α} {o : part α}, a ∈ o → b ∈ o → a = b
| _ _ ⟨p, f⟩ ⟨h₁, rfl⟩ ⟨h₂, rfl⟩ := rfl

theorem mem.left_unique : relator.left_unique ((∈) : α → part α → Prop) :=
λ a o b, mem_unique

theorem get_eq_of_mem {o : part α} {a} (h : a ∈ o) (h') : get o h' = a :=
mem_unique ⟨_, rfl⟩ h

protected theorem subsingleton (o : part α) : set.subsingleton {a | a ∈ o} :=
λ a ha b hb, mem_unique ha hb

@[simp] theorem get_some {a : α} (ha : (some a).dom) : get (some a) ha = a := rfl

theorem mem_some (a : α) : a ∈ some a := ⟨trivial, rfl⟩

@[simp] theorem mem_some_iff {a b} : b ∈ (some a : part α) ↔ b = a :=
⟨λ⟨h, e⟩, e.symm, λ e, ⟨trivial, e.symm⟩⟩

theorem eq_some_iff {a : α} {o : part α} : o = some a ↔ a ∈ o :=
⟨λ e, e.symm ▸ mem_some _,
 λ ⟨h, e⟩, e ▸ ext' (iff_true_intro h) (λ _ _, rfl)⟩

theorem eq_none_iff {o : part α} : o = none ↔ ∀ a, a ∉ o :=
⟨λ e, e.symm ▸ not_mem_none, λ h, ext (by simpa)⟩

theorem eq_none_iff' {o : part α} : o = none ↔ ¬ o.dom :=
⟨λ e, e.symm ▸ id, λ h, eq_none_iff.2 (λ a h', h h'.fst)⟩

@[simp] lemma some_ne_none (x : α) : some x ≠ none :=
by { intro h, change none.dom, rw [← h], trivial }

@[simp] lemma none_ne_some (x : α) : none ≠ some x :=
(some_ne_none x).symm

lemma ne_none_iff {o : part α} : o ≠ none ↔ ∃ x, o = some x :=
begin
  split,
  { rw [ne, eq_none_iff', not_not], exact λ h, ⟨o.get h, eq_some_iff.2 (get_mem h)⟩ },
  { rintro ⟨x, rfl⟩, apply some_ne_none }
end

lemma eq_none_or_eq_some (o : part α) : o = none ∨ ∃ x, o = some x :=
or_iff_not_imp_left.2 ne_none_iff.1

lemma some_injective : injective (@part.some α) :=
λ a b h, congr_fun (eq_of_heq (part.mk.inj h).2) trivial

@[simp] lemma some_inj {a b : α} : part.some a = some b ↔ a = b := some_injective.eq_iff

@[simp] lemma some_get {a : part α} (ha : a.dom) :
  part.some (part.get a ha) = a :=
eq.symm (eq_some_iff.2 ⟨ha, rfl⟩)

lemma get_eq_iff_eq_some {a : part α} {ha : a.dom} {b : α} :
  a.get ha = b ↔ a = some b :=
⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

lemma get_eq_get_of_eq (a : part α) (ha : a.dom) {b : part α} (h : a = b) :
  a.get ha = b.get (h ▸ ha) :=
by { congr, exact h }

lemma get_eq_iff_mem {o : part α} {a : α} (h : o.dom) : o.get h = a ↔ a ∈ o :=
⟨λ H, ⟨h, H⟩, λ ⟨h', H⟩, H⟩

lemma eq_get_iff_mem {o : part α} {a : α} (h : o.dom) : a = o.get h ↔ a ∈ o :=
eq_comm.trans (get_eq_iff_mem h)

@[simp] lemma none_to_option [decidable (@none α).dom] : (none : part α).to_option = option.none :=
dif_neg id

@[simp] lemma some_to_option (a : α) [decidable (some a).dom] :
  (some a).to_option = option.some a :=
dif_pos trivial

instance none_decidable : decidable (@none α).dom := decidable.false
instance some_decidable (a : α) : decidable (some a).dom := decidable.true

/-- Retrieves the value of `a : part α` if it exists, and return the provided default value
otherwise. -/
def get_or_else (a : part α) [decidable a.dom] (d : α) :=
if ha : a.dom then a.get ha else d

@[simp] lemma get_or_else_none (d : α) [decidable (none : part α).dom] : get_or_else none d = d :=
dif_neg id

@[simp] lemma get_or_else_some (a : α) (d : α) [decidable (some a).dom] :
  get_or_else (some a) d = a :=
dif_pos trivial

@[simp] theorem mem_to_option {o : part α} [decidable o.dom] {a : α} :
  a ∈ to_option o ↔ a ∈ o :=
begin
  unfold to_option,
  by_cases h : o.dom; simp [h],
  { exact ⟨λ h, ⟨_, h⟩, λ ⟨_, h⟩, h⟩ },
  { exact mt Exists.fst h }
end

protected lemma dom.to_option {o : part α} [decidable o.dom] (h : o.dom) : o.to_option = o.get h :=
dif_pos h

lemma to_option_eq_none_iff {a : part α} [decidable a.dom] : a.to_option = option.none ↔ ¬ a.dom :=
ne.dite_eq_right_iff $ λ h, option.some_ne_none _

@[simp] lemma elim_to_option {α β : Type*} (a : part α) [decidable a.dom] (b : β) (f : α → β) :
  a.to_option.elim b f = if h : a.dom then f (a.get h) else b :=
begin
  split_ifs,
  { rw h.to_option,
    refl },
  { rw part.to_option_eq_none_iff.2 h,
    refl }
end

/-- Converts an `option α` into a `part α`. -/
def of_option : option α → part α
| option.none     := none
| (option.some a) := some a

@[simp] theorem mem_of_option {a : α} : ∀ {o : option α}, a ∈ of_option o ↔ a ∈ o
| option.none     := ⟨λ h, h.fst.elim, λ h, option.no_confusion h⟩
| (option.some b) := ⟨λ h, congr_arg option.some h.snd,
  λ h, ⟨trivial, option.some.inj h⟩⟩

@[simp] theorem of_option_dom {α} : ∀ (o : option α), (of_option o).dom ↔ o.is_some
| option.none     := by simp [of_option, none]
| (option.some a) := by simp [of_option]

theorem of_option_eq_get {α} (o : option α) : of_option o = ⟨_, @option.get _ o⟩ :=
part.ext' (of_option_dom o) $ λ h₁ h₂, by cases o; [cases h₁, refl]

instance : has_coe (option α) (part α) := ⟨of_option⟩

@[simp] theorem mem_coe {a : α} {o : option α} :
  a ∈ (o : part α) ↔ a ∈ o := mem_of_option

@[simp] theorem coe_none : (@option.none α : part α) = none := rfl
@[simp] theorem coe_some (a : α) : (option.some a : part α) = some a := rfl

@[elab_as_eliminator] protected lemma induction_on {P : part α → Prop}
  (a : part α) (hnone : P none) (hsome : ∀ a : α, P (some a)) : P a :=
(classical.em a.dom).elim
  (λ h, part.some_get h ▸ hsome _)
  (λ h, (eq_none_iff'.2 h).symm ▸ hnone)

instance of_option_decidable : ∀ o : option α, decidable (of_option o).dom
| option.none     := part.none_decidable
| (option.some a) := part.some_decidable a

@[simp] theorem to_of_option (o : option α) : to_option (of_option o) = o :=
by cases o; refl

@[simp] theorem of_to_option (o : part α) [decidable o.dom] : of_option (to_option o) = o :=
ext $ λ a, mem_of_option.trans mem_to_option

/-- `part α` is (classically) equivalent to `option α`. -/
noncomputable def equiv_option : part α ≃ option α :=
by haveI := classical.dec; exact
⟨λ o, to_option o, of_option, λ o, of_to_option o,
 λ o, eq.trans (by dsimp; congr) (to_of_option o)⟩

/-- We give `part α` the order where everything is greater than `none`. -/
instance : partial_order (part α) :=
{ le := λ x y, ∀ i, i ∈ x → i ∈ y,
  le_refl := λ x y, id,
  le_trans := λ x y z f g i, g _ ∘ f _,
  le_antisymm := λ x y f g, part.ext $ λ z, ⟨f _, g _⟩ }

instance : order_bot (part α) :=
{ bot := none,
  bot_le := by { introv x, rintro ⟨⟨_⟩,_⟩, } }

lemma le_total_of_le_of_le {x y : part α} (z : part α) (hx : x ≤ z) (hy : y ≤ z) :
  x ≤ y ∨ y ≤ x :=
begin
  rcases part.eq_none_or_eq_some x with h | ⟨b, h₀⟩,
  { rw h, left, apply order_bot.bot_le _ },
  right, intros b' h₁,
  rw part.eq_some_iff at h₀,
  replace hx := hx _ h₀, replace hy := hy _ h₁,
  replace hx := part.mem_unique hx hy, subst hx,
  exact h₀
end

/-- `assert p f` is a bind-like operation which appends an additional condition
  `p` to the domain and uses `f` to produce the value. -/
def assert (p : Prop) (f : p → part α) : part α :=
⟨∃ h : p, (f h).dom, λha, (f ha.fst).get ha.snd⟩

/-- The bind operation has value `g (f.get)`, and is defined when all the
  parts are defined. -/
protected def bind (f : part α) (g : α → part β) : part β :=
assert (dom f) (λb, g (f.get b))

/-- The map operation for `part` just maps the value and maintains the same domain. -/
@[simps] def map (f : α → β) (o : part α) : part β :=
⟨o.dom, f ∘ o.get⟩

theorem mem_map (f : α → β) {o : part α} :
  ∀ {a}, a ∈ o → f a ∈ map f o
| _ ⟨h, rfl⟩ := ⟨_, rfl⟩

@[simp] theorem mem_map_iff (f : α → β) {o : part α} {b} :
  b ∈ map f o ↔ ∃ a ∈ o, f a = b :=
⟨match b with _, ⟨h, rfl⟩ := ⟨_, ⟨_, rfl⟩, rfl⟩ end,
 λ ⟨a, h₁, h₂⟩, h₂ ▸ mem_map f h₁⟩

@[simp] theorem map_none (f : α → β) :
  map f none = none := eq_none_iff.2 $ λ a, by simp

@[simp] theorem map_some (f : α → β) (a : α) : map f (some a) = some (f a) :=
eq_some_iff.2 $ mem_map f $ mem_some _

theorem mem_assert {p : Prop} {f : p → part α}
  : ∀ {a} (h : p), a ∈ f h → a ∈ assert p f
| _ x ⟨h, rfl⟩ := ⟨⟨x, h⟩, rfl⟩

@[simp] theorem mem_assert_iff {p : Prop} {f : p → part α} {a} :
  a ∈ assert p f ↔ ∃ h : p, a ∈ f h :=
⟨match a with _, ⟨h, rfl⟩ := ⟨_, ⟨_, rfl⟩⟩ end,
 λ ⟨a, h⟩, mem_assert _ h⟩

lemma assert_pos {p : Prop} {f : p → part α} (h : p) :
  assert p f = f h :=
begin
  dsimp [assert],
  cases h' : f h,
  simp only [h', h, true_and, iff_self, exists_prop_of_true, eq_iff_iff],
  apply function.hfunext,
  { simp only [h,h',exists_prop_of_true] },
  { cc }
end

lemma assert_neg {p : Prop} {f : p → part α} (h : ¬ p) :
  assert p f = none :=
begin
  dsimp [assert,none], congr,
  { simp only [h, not_false_iff, exists_prop_of_false] },
  { apply function.hfunext,
    { simp only [h, not_false_iff, exists_prop_of_false] },
    cc },
end

theorem mem_bind {f : part α} {g : α → part β} :
  ∀ {a b}, a ∈ f → b ∈ g a → b ∈ f.bind g
| _ _ ⟨h, rfl⟩ ⟨h₂, rfl⟩ := ⟨⟨h, h₂⟩, rfl⟩

@[simp] theorem mem_bind_iff {f : part α} {g : α → part β} {b} :
  b ∈ f.bind g ↔ ∃ a ∈ f, b ∈ g a :=
⟨match b with _, ⟨⟨h₁, h₂⟩, rfl⟩ := ⟨_, ⟨_, rfl⟩, ⟨_, rfl⟩⟩ end,
 λ ⟨a, h₁, h₂⟩, mem_bind h₁ h₂⟩

protected lemma dom.bind {o : part α} (h : o.dom) (f : α → part β) : o.bind f = f (o.get h) :=
begin
  ext b,
  simp only [part.mem_bind_iff, exists_prop],
  refine ⟨_, λ hb, ⟨o.get h, part.get_mem _, hb⟩⟩,
  rintro ⟨a, ha, hb⟩,
  rwa part.get_eq_of_mem ha,
end

lemma dom.of_bind {f : α → part β} {a : part α} (h : (a.bind f).dom) : a.dom := h.some

@[simp] theorem bind_none (f : α → part β) :
  none.bind f = none := eq_none_iff.2 $ λ a, by simp

@[simp] theorem bind_some (a : α) (f : α → part β) :
  (some a).bind f = f a := ext $ by simp

theorem bind_of_mem {o : part α} {a : α} (h : a ∈ o) (f : α → part β) :
  o.bind f = f a :=
by rw [eq_some_iff.2 h, bind_some]

theorem bind_some_eq_map (f : α → β) (x : part α) :
  x.bind (some ∘ f) = map f x :=
ext $ by simp [eq_comm]

lemma bind_to_option (f : α → part β) (o : part α) [decidable o.dom] [Π a, decidable (f a).dom]
  [decidable (o.bind f).dom] :
  (o.bind f).to_option = o.to_option.elim option.none (λ a, (f a).to_option) :=
begin
  by_cases o.dom,
  { simp_rw [h.to_option, h.bind],
    refl },
  { rw part.to_option_eq_none_iff.2 h,
    exact part.to_option_eq_none_iff.2 (λ ho, h ho.of_bind) }
end

theorem bind_assoc {γ} (f : part α) (g : α → part β) (k : β → part γ) :
  (f.bind g).bind k = f.bind (λ x, (g x).bind k) :=
ext $ λ a, by simp; exact
 ⟨λ ⟨_, ⟨_, h₁, h₂⟩, h₃⟩, ⟨_, h₁, _, h₂, h₃⟩,
  λ ⟨_, h₁, _, h₂, h₃⟩, ⟨_, ⟨_, h₁, h₂⟩, h₃⟩⟩

@[simp] theorem bind_map {γ} (f : α → β) (x) (g : β → part γ) :
  (map f x).bind g = x.bind (λ y, g (f y)) :=
by rw [← bind_some_eq_map, bind_assoc]; simp

@[simp] theorem map_bind {γ} (f : α → part β) (x : part α) (g : β → γ) :
  map g (x.bind f) = x.bind (λ y, map g (f y)) :=
by rw [← bind_some_eq_map, bind_assoc]; simp [bind_some_eq_map]

theorem map_map (g : β → γ) (f : α → β) (o : part α) :
  map g (map f o) = map (g ∘ f) o :=
by rw [← bind_some_eq_map, bind_map, bind_some_eq_map]

instance : monad part :=
{ pure := @some,
  map := @map,
  bind := @part.bind }

instance : is_lawful_monad part :=
{ bind_pure_comp_eq_map := @bind_some_eq_map,
  id_map := λ β f, by cases f; refl,
  pure_bind := @bind_some,
  bind_assoc := @bind_assoc }

theorem map_id' {f : α → α} (H : ∀ (x : α), f x = x) (o) : map f o = o :=
by rw [show f = id, from funext H]; exact id_map o

@[simp] theorem bind_some_right (x : part α) : x.bind some = x :=
by rw [bind_some_eq_map]; simp [map_id']

@[simp] theorem pure_eq_some (a : α) : pure a = some a := rfl
@[simp] theorem ret_eq_some (a : α) : return a = some a := rfl

@[simp] theorem map_eq_map {α β} (f : α → β) (o : part α) :
  f <$> o = map f o := rfl

@[simp] theorem bind_eq_bind {α β} (f : part α) (g : α → part β) :
  f >>= g = f.bind g := rfl

lemma bind_le {α} (x : part α) (f : α → part β) (y : part β) :
  x >>= f ≤ y ↔ (∀ a, a ∈ x → f a ≤ y) :=
begin
  split; intro h,
  { intros a h' b, replace h := h b,
    simp only [and_imp, exists_prop, bind_eq_bind, mem_bind_iff, exists_imp_distrib] at h,
    apply h _ h' },
  { intros b h',
    simp only [exists_prop, bind_eq_bind, mem_bind_iff] at h',
    rcases h' with ⟨a,h₀,h₁⟩, apply h _ h₀ _ h₁ },
end

instance : monad_fail part :=
{ fail := λ_ _, none, ..part.monad }

/-- `restrict p o h` replaces the domain of `o` with `p`, and is well defined when
  `p` implies `o` is defined. -/
def restrict (p : Prop) (o : part α) (H : p → o.dom) : part α :=
⟨p, λh, o.get (H h)⟩

@[simp]
theorem mem_restrict (p : Prop) (o : part α) (h : p → o.dom) (a : α) :
  a ∈ restrict p o h ↔ p ∧ a ∈ o :=
begin
  dsimp [restrict, mem_eq], split,
  { rintro ⟨h₀, h₁⟩, exact ⟨h₀, ⟨_, h₁⟩⟩ },
  rintro ⟨h₀, h₁, h₂⟩, exact ⟨h₀, h₂⟩
end

/-- `unwrap o` gets the value at `o`, ignoring the condition. This function is unsound. -/
meta def unwrap (o : part α) : α := o.get undefined

theorem assert_defined {p : Prop} {f : p → part α} :
  ∀ (h : p), (f h).dom → (assert p f).dom := exists.intro

theorem bind_defined {f : part α} {g : α → part β} :
  ∀ (h : f.dom), (g (f.get h)).dom → (f.bind g).dom := assert_defined

@[simp] theorem bind_dom {f : part α} {g : α → part β} :
  (f.bind g).dom ↔ ∃ h : f.dom, (g (f.get h)).dom := iff.rfl

section instances

/- We define several instances for constants and operations on `part α` inherited from `α`. -/

@[to_additive] instance [has_one α] : has_one (part α) := { one := pure 1 }
@[to_additive] instance [has_mul α] : has_mul (part α) := { mul := λ a b, (*) <$> a <*> b }
@[to_additive] instance [has_inv α] : has_inv (part α) := { inv := map has_inv.inv }
@[to_additive] instance [has_div α] : has_div (part α) := { div := λ a b, (/) <$> a <*> b }
instance [has_mod α] : has_mod (part α) := { mod := λ a b, (%) <$> a <*> b }
instance [has_append α] : has_append (part α) := { append := λ a b, (++) <$> a <*> b }
instance [has_inter α] : has_inter (part α) := { inter := λ a b, (∩) <$> a <*> b }
instance [has_union α] : has_union (part α) := { union := λ a b, (∪) <$> a <*> b }
instance [has_sdiff α] : has_sdiff (part α) := { sdiff := λ a b, (\) <$> a <*> b }

@[to_additive]
lemma one_mem_one [has_one α] : (1 : α) ∈ (1 : part α) := ⟨trivial, rfl⟩

@[to_additive]
lemma mul_mem_mul [has_mul α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma * mb ∈ a * b := by tidy

@[to_additive]
lemma left_dom_of_mul_dom [has_mul α] {a b : part α} (hab : dom (a * b)) :
  a.dom := by tidy

@[to_additive]

@[simp, to_additive]
lemma mul_get_eq [has_mul α] (a b : part α) (hab : dom (a * b)) :
  (a * b).get hab = a.get (left_dom_of_mul_dom hab) * b.get (right_dom_of_mul_dom hab) :=
by tidy

@[to_additive]
lemma some_mul_some [has_mul α] (a b : α) : some a * some b = some (a * b) := by tidy

@[to_additive]
lemma inv_mem_inv [has_inv α] (a : part α) (ma : α) (ha : ma ∈ a) : ma⁻¹ ∈ a⁻¹ := by tidy

@[to_additive]
lemma inv_some [has_inv α] (a : α) : (some a)⁻¹ = some (a⁻¹) := rfl

@[to_additive]
lemma div_mem_div [has_div α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma / mb ∈ a / b := by tidy

@[to_additive]
lemma left_dom_of_div_dom [has_div α] {a b : part α} (hab : dom (a / b)) :
  a.dom := by tidy

@[to_additive]
lemma right_dom_of_div_dom [has_div α] {a b : part α} (hab : dom (a / b)) :
  b.dom := by tidy

@[simp, to_additive]
lemma div_get_eq [has_div α] (a b : part α) (hab : dom (a / b)) :
  (a / b).get hab = a.get (left_dom_of_div_dom hab) / b.get (right_dom_of_div_dom hab) :=
by tidy

@[to_additive]
lemma some_div_some [has_div α] (a b : α) : some a / some b = some (a / b) := by tidy

lemma mod_mem_mod [has_mod α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma % mb ∈ a % b := by tidy

lemma left_dom_of_mod_dom [has_mod α] {a b : part α} (hab : dom (a % b)) :
  a.dom := by tidy

lemma right_dom_of_mod_dom [has_mod α] {a b : part α} (hab : dom (a % b)) :
  b.dom := by tidy

@[simp]
lemma mod_get_eq [has_mod α] (a b : part α) (hab : dom (a % b)) :
  (a % b).get hab = a.get (left_dom_of_mod_dom hab) % b.get (right_dom_of_mod_dom hab) :=
by tidy

lemma some_mod_some [has_mod α] (a b : α) : some a % some b = some (a % b) := by tidy

lemma append_mem_append [has_append α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma ++ mb ∈ a ++ b := by tidy

lemma left_dom_of_append_dom [has_append α] {a b : part α} (hab : dom (a ++ b)) :
  a.dom := by tidy

lemma right_dom_of_append_dom [has_append α] {a b : part α} (hab : dom (a ++ b)) :
  b.dom := by tidy

@[simp]
lemma append_get_eq [has_append α] (a b : part α) (hab : dom (a ++ b)) :
  (a ++ b).get hab = a.get (left_dom_of_append_dom hab) ++ b.get (right_dom_of_append_dom hab) :=
by tidy

lemma some_append_some [has_append α] (a b : α) : some a ++ some b = some (a ++ b) := by tidy

lemma inter_mem_inter [has_inter α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma ∩ mb ∈ a ∩ b := by tidy

lemma left_dom_of_inter_dom [has_inter α] {a b : part α} (hab : dom (a ∩ b)) :
  a.dom := by tidy

lemma right_dom_of_inter_dom [has_inter α] {a b : part α} (hab : dom (a ∩ b)) :
  b.dom := by tidy

@[simp]
lemma inter_get_eq [has_inter α] (a b : part α) (hab : dom (a ∩ b)) :
  (a ∩ b).get hab = a.get (left_dom_of_inter_dom hab) ∩ b.get (right_dom_of_inter_dom hab) :=
by tidy

lemma some_inter_some [has_inter α] (a b : α) : some a ∩ some b = some (a ∩ b) := by tidy

lemma union_mem_union [has_union α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma ∪ mb ∈ a ∪ b := by tidy

lemma left_dom_of_union_dom [has_union α] {a b : part α} (hab : dom (a ∪ b)) :
  a.dom := by tidy

lemma right_dom_of_union_dom [has_union α] {a b : part α} (hab : dom (a ∪ b)) :
  b.dom := by tidy

@[simp]
lemma union_get_eq [has_union α] (a b : part α) (hab : dom (a ∪ b)) :
  (a ∪ b).get hab = a.get (left_dom_of_union_dom hab) ∪ b.get (right_dom_of_union_dom hab) :=
by tidy

lemma some_union_some [has_union α] (a b : α) : some a ∪ some b = some (a ∪ b) := by tidy

lemma sdiff_mem_sdiff [has_sdiff α] (a b : part α) (ma mb : α) (ha : ma ∈ a) (hb : mb ∈ b) :
  ma \ mb ∈ a \ b := by tidy

lemma left_dom_of_sdiff_dom [has_sdiff α] {a b : part α} (hab : dom (a \ b)) :
  a.dom := by tidy

lemma right_dom_of_sdiff_dom [has_sdiff α] {a b : part α} (hab : dom (a \ b)) :
  b.dom := by tidy

@[simp]
lemma sdiff_get_eq [has_sdiff α] (a b : part α) (hab : dom (a \ b)) :
  (a \ b).get hab = a.get (left_dom_of_sdiff_dom hab) \ b.get (right_dom_of_sdiff_dom hab) :=
by tidy

lemma some_sdiff_some [has_sdiff α] (a b : α) : some a \ some b = some (a \ b) := by tidy

end instances

end part


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash

! This file was ported from Lean 3 source module algebra.lie.direct_sum
! leanprover-community/mathlib commit c0cc689babd41c0e9d5f02429211ffbe2403472a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.DirectSum.Module
import Mathbin.Algebra.Lie.OfAssociative
import Mathbin.Algebra.Lie.Submodule
import Mathbin.Algebra.Lie.Basic

/-!
# Direct sums of Lie algebras and Lie modules

Direct sums of Lie algebras and Lie modules carry natural algebra and module structures.

## Tags

lie algebra, lie module, direct sum
-/

universe u v w w₁

namespace DirectSum

open Dfinsupp

open DirectSum

variable {R : Type u} {ι : Type v} [CommRing R]

section Modules

/-! The direct sum of Lie modules over a fixed Lie algebra carries a natural Lie module
structure. -/

variable {L : Type w₁} {M : ι → Type w}

variable [LieRing L] [LieAlgebra R L]

variable [∀ i, AddCommGroup (M i)] [∀ i, Module R (M i)]

variable [∀ i, LieRingModule L (M i)] [∀ i, LieModule R L (M i)]

instance : LieRingModule L (⨁ i, M i)
    where
  bracket x m := m.mapRange (fun i m' => ⁅x, m'⁆) fun i => lie_zero x
  add_lie x y m := by
    ext
    simp only [map_range_apply, add_apply, add_lie]
  lie_add x m n := by
    ext
    simp only [map_range_apply, add_apply, lie_add]
  leibniz_lie x y m := by
    ext
    simp only [map_range_apply, lie_lie, add_apply, sub_add_cancel]

@[simp]
theorem lie_module_bracket_apply (x : L) (m : ⨁ i, M i) (i : ι) : ⁅x, m⁆ i = ⁅x, m i⁆ :=
  mapRange_apply _ _ m i
#align direct_sum.lie_module_bracket_apply DirectSum.lie_module_bracket_apply

instance : LieModule R L (⨁ i, M i)
    where
  smul_lie t x m := by
    ext i
    simp only [smul_lie, lie_module_bracket_apply, smul_apply]
  lie_smul t x m := by
    ext i
    simp only [lie_smul, lie_module_bracket_apply, smul_apply]

variable (R ι L M)

/-- The inclusion of each component into a direct sum as a morphism of Lie modules. -/
def lieModuleOf [DecidableEq ι] (j : ι) : M j →ₗ⁅R,L⁆ ⨁ i, M i :=
  { lof R ι M j with
    map_lie' := fun x m => by
      ext i; by_cases h : j = i
      · rw [← h]
        simp
      · simp [lof, single_eq_of_ne h] }
#align direct_sum.lie_module_of DirectSum.lieModuleOf

/-- The projection map onto one component, as a morphism of Lie modules. -/
def lieModuleComponent (j : ι) : (⨁ i, M i) →ₗ⁅R,L⁆ M j :=
  { component R ι M j with
    map_lie' := fun x m => by
      simp only [component, lapply_apply, lie_module_bracket_apply, LinearMap.toFun_eq_coe] }
#align direct_sum.lie_module_component DirectSum.lieModuleComponent

end Modules

section Algebras

/-! The direct sum of Lie algebras carries a natural Lie algebra structure. -/

variable (L : ι → Type w)

variable [∀ i, LieRing (L i)] [∀ i, LieAlgebra R (L i)]

instance lieRing : LieRing (⨁ i, L i) :=
  {
    (inferInstance :
      AddCommGroup
        _) with
    bracket := zipWith (fun i => fun x y => ⁅x, y⁆) fun i => lie_zero 0
    add_lie := fun x y z => by
      ext
      simp only [zip_with_apply, add_apply, add_lie]
    lie_add := fun x y z => by
      ext
      simp only [zip_with_apply, add_apply, lie_add]
    lie_self := fun x => by
      ext
      simp only [zip_with_apply, add_apply, lie_self, zero_apply]
    leibniz_lie := fun x y z => by
      ext
      simp only [sub_apply, zip_with_apply, add_apply, zero_apply]
      apply leibniz_lie }
#align direct_sum.lie_ring DirectSum.lieRing

@[simp]
theorem bracket_apply (x y : ⨁ i, L i) (i : ι) : ⁅x, y⁆ i = ⁅x i, y i⁆ :=
  zipWith_apply _ _ x y i
#align direct_sum.bracket_apply DirectSum.bracket_apply

instance lieAlgebra : LieAlgebra R (⨁ i, L i) :=
  { (inferInstance : Module R _) with
    lie_smul := fun c x y => by
      ext
      simp only [zip_with_apply, smul_apply, bracket_apply, lie_smul] }
#align direct_sum.lie_algebra DirectSum.lieAlgebra

variable (R ι L)

/-- The inclusion of each component into the direct sum as morphism of Lie algebras. -/
@[simps]
def lieAlgebraOf [DecidableEq ι] (j : ι) : L j →ₗ⁅R⁆ ⨁ i, L i :=
  { lof R ι L j with
    toFun := of L j
    map_lie' := fun x y => by
      ext i
      by_cases h : j = i
      · rw [← h]
        simp [of]
      · simp [of, single_eq_of_ne h] }
#align direct_sum.lie_algebra_of DirectSum.lieAlgebraOf

/-- The projection map onto one component, as a morphism of Lie algebras. -/
@[simps]
def lieAlgebraComponent (j : ι) : (⨁ i, L i) →ₗ⁅R⁆ L j :=
  { component R ι L j with
    toFun := component R ι L j
    map_lie' := fun x y => by
      simp only [component, bracket_apply, lapply_apply, LinearMap.toFun_eq_coe] }
#align direct_sum.lie_algebra_component DirectSum.lieAlgebraComponent

@[ext]
theorem lieAlgebra_ext {x y : ⨁ i, L i}
    (h : ∀ i, lieAlgebraComponent R ι L i x = lieAlgebraComponent R ι L i y) : x = y :=
  Dfinsupp.ext h
#align direct_sum.lie_algebra_ext DirectSum.lieAlgebra_ext

include R

theorem lie_of_of_ne [DecidableEq ι] {i j : ι} (hij : j ≠ i) (x : L i) (y : L j) :
    ⁅of L i x, of L j y⁆ = 0 := by
  apply lie_algebra_ext R ι L; intro k
  rw [LieHom.map_lie]
  simp only [component, of, lapply_apply, single_add_hom_apply, lie_algebra_component_apply,
    single_apply, zero_apply]
  by_cases hik : i = k
  · simp only [dif_neg, not_false_iff, lie_zero, hik.symm, hij]
  · simp only [dif_neg, not_false_iff, zero_lie, hik]
#align direct_sum.lie_of_of_ne DirectSum.lie_of_of_ne

theorem lie_of_of_eq [DecidableEq ι] {i j : ι} (hij : j = i) (x : L i) (y : L j) :
    ⁅of L i x, of L j y⁆ = of L i ⁅x, hij.recOn y⁆ :=
  by
  have : of L j y = of L i (hij.rec_on y) := Eq.drec (Eq.refl _) hij
  rw [this, ← lie_algebra_of_apply R ι L i ⁅x, hij.rec_on y⁆, LieHom.map_lie, lie_algebra_of_apply,
    lie_algebra_of_apply]
#align direct_sum.lie_of_of_eq DirectSum.lie_of_of_eq

@[simp]
theorem lie_of [DecidableEq ι] {i j : ι} (x : L i) (y : L j) :
    ⁅of L i x, of L j y⁆ = if hij : j = i then lieAlgebraOf R ι L i ⁅x, hij.recOn y⁆ else 0 :=
  by
  by_cases hij : j = i
  · simp only [lie_of_of_eq R ι L hij x y, hij, dif_pos, not_false_iff, lie_algebra_of_apply]
  · simp only [lie_of_of_ne R ι L hij x y, hij, dif_neg, not_false_iff]
#align direct_sum.lie_of DirectSum.lie_of

variable {R L ι}

/-- Given a family of Lie algebras `L i`, together with a family of morphisms of Lie algebras
`f i : L i →ₗ⁅R⁆ L'` into a fixed Lie algebra `L'`, we have a natural linear map:
`(⨁ i, L i) →ₗ[R] L'`. If in addition `⁅f i x, f j y⁆ = 0` for any `x ∈ L i` and `y ∈ L j` (`i ≠ j`)
then this map is a morphism of Lie algebras. -/
@[simps]
def toLieAlgebra [DecidableEq ι] (L' : Type w₁) [LieRing L'] [LieAlgebra R L']
    (f : ∀ i, L i →ₗ⁅R⁆ L') (hf : ∀ i j : ι, i ≠ j → ∀ (x : L i) (y : L j), ⁅f i x, f j y⁆ = 0) :
    (⨁ i, L i) →ₗ⁅R⁆ L' :=
  {/- The goal is linear in `y`. We can use this to reduce to the case that `y` has only one
              non-zero component. -/
      -- Similarly, we can reduce to the case that `x` has only one non-zero component.
      -- Tidy up and use `lie_of`.
      -- And finish with trivial case analysis.
      toModule
      R ι L' fun i =>
      (f i : L i →ₗ[R]
          L') with
    toFun := toModule R ι L' fun i => (f i : L i →ₗ[R] L')
    map_lie' := fun x y => by
      let f' i := (f i : L i →ₗ[R] L')
      suffices
        ∀ (i : ι) (y : L i),
          to_module R ι L' f' ⁅x, of L i y⁆ =
            ⁅to_module R ι L' f' x, to_module R ι L' f' (of L i y)⁆
        by
        simp only [← LieAlgebra.ad_apply R]
        rw [← LinearMap.comp_apply, ← LinearMap.comp_apply]
        congr
        clear y
        ext (i y)
        exact this i y
      suffices
        ∀ (i j) (y : L i) (x : L j),
          to_module R ι L' f' ⁅of L j x, of L i y⁆ =
            ⁅to_module R ι L' f' (of L j x), to_module R ι L' f' (of L i y)⁆
        by
        intro i y
        rw [← lie_skew x, ← lie_skew (to_module R ι L' f' x)]
        simp only [LinearMap.map_neg, neg_inj, ← LieAlgebra.ad_apply R]
        rw [← LinearMap.comp_apply, ← LinearMap.comp_apply]
        congr
        clear x
        ext (j x)
        exact this j i x y
      intro i j y x
      simp only [lie_of R, lie_algebra_of_apply, LieHom.coe_toLinearMap, to_add_monoid_of,
        coe_to_module_eq_coe_to_add_monoid, LinearMap.toAddMonoidHom_coe]
      rcases eq_or_ne i j with (h | h)
      · have h' : f j (h.rec_on y) = f i y := Eq.drec (Eq.refl _) h
        simp only [h, h', LieHom.coe_toLinearMap, dif_pos, LieHom.map_lie, to_add_monoid_of,
          LinearMap.toAddMonoidHom_coe]
      · simp only [h, hf j i h.symm x y, dif_neg, not_false_iff, AddMonoidHom.map_zero] }
#align direct_sum.to_lie_algebra DirectSum.toLieAlgebra

end Algebras

section Ideals

variable {L : Type w} [LieRing L] [LieAlgebra R L] (I : ι → LieIdeal R L)

/-- The fact that this instance is necessary seems to be a bug in typeclass inference. See
[this Zulip thread](https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/
Typeclass.20resolution.20under.20binders/near/245151099). -/
instance lieRingOfIdeals : LieRing (⨁ i, I i) :=
  DirectSum.lieRing fun i => ↥(I i)
#align direct_sum.lie_ring_of_ideals DirectSum.lieRingOfIdeals

/-- See `direct_sum.lie_ring_of_ideals` comment. -/
instance lieAlgebraOfIdeals : LieAlgebra R (⨁ i, I i) :=
  DirectSum.lieAlgebra fun i => ↥(I i)
#align direct_sum.lie_algebra_of_ideals DirectSum.lieAlgebraOfIdeals

end Ideals

end DirectSum


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import data.rat.order
import data.int.char_zero

/-!
# Casts for Rational Numbers

## Summary

We define the canonical injection from ℚ into an arbitrary division ring and prove various
casting lemmas showing the well-behavedness of this injection.

## Notations

- `/.` is infix notation for `rat.mk`.

## Tags

rat, rationals, field, ℚ, numerator, denominator, num, denom, cast, coercion, casting
-/

namespace rat
variable {α : Type*}
open_locale rat

section with_div_ring
variable [division_ring α]

/-- Construct the canonical injection from `ℚ` into an arbitrary
  division ring. If the field has positive characteristic `p`,
  we define `1 / p = 1 / 0 = 0` for consistency with our
  division by zero convention. -/
-- see Note [coercion into rings]
@[priority 900] instance cast_coe : has_coe_t ℚ α := ⟨λ r, r.1 / r.2⟩

theorem cast_def (r : ℚ) : (r : α) = r.num / r.denom := rfl

@[simp] theorem cast_of_int (n : ℤ) : (of_int n : α) = n :=
show (n / (1:ℕ) : α) = n, by rw [nat.cast_one, div_one]

@[simp, norm_cast] theorem cast_coe_int (n : ℤ) : ((n : ℚ) : α) = n :=
by rw [coe_int_eq_of_int, cast_of_int]

@[simp, norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℚ) : α) = n := cast_coe_int n

@[simp, norm_cast] theorem cast_zero : ((0 : ℚ) : α) = 0 :=
(cast_of_int _).trans int.cast_zero

@[simp, norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1 :=
(cast_of_int _).trans int.cast_one

theorem cast_commute (r : ℚ) (a : α) : commute ↑r a :=
(r.1.cast_commute a).div_left (r.2.cast_commute a)

theorem cast_comm (r : ℚ) (a : α) : (r : α) * a = a * r :=
(cast_commute r a).eq

theorem commute_cast (a : α) (r : ℚ) : commute a r :=
(r.cast_commute a).symm

@[norm_cast] theorem cast_mk_of_ne_zero (a b : ℤ)
  (b0 : (b:α) ≠ 0) : (a /. b : α) = a / b :=
begin
  have b0' : b ≠ 0, { refine mt _ b0, simp {contextual := tt} },
  cases e : a /. b with n d h c,
  have d0 : (d:α) ≠ 0,
  { intro d0,
    have dd := denom_dvd a b,
    cases (show (d:ℤ) ∣ b, by rwa e at dd) with k ke,
    have : (b:α) = (d:α) * (k:α), {rw [ke, int.cast_mul], refl},
    rw [d0, zero_mul] at this, contradiction },
  rw [num_denom'] at e,
  have := congr_arg (coe : ℤ → α) ((mk_eq b0' $ ne_of_gt $ int.coe_nat_pos.2 h).1 e),
  rw [int.cast_mul, int.cast_mul, int.cast_coe_nat] at this,
  symmetry, change (a / b : α) = n / d,
  rw [div_eq_mul_inv, eq_div_iff_mul_eq d0, mul_assoc, (d.commute_cast _).eq,
      ← mul_assoc, this, mul_assoc, mul_inv_cancel b0, mul_one]
end

@[norm_cast] theorem cast_add_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m + n : ℚ) : α) = m + n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 rfl),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 rfl),
  rw [num_denom', num_denom', add_def d₁0' d₂0'],
  suffices : (n₁ * (d₂ * (d₂⁻¹ * d₁⁻¹)) +
    n₂ * (d₁ * d₂⁻¹) * d₁⁻¹ : α) = n₁ * d₁⁻¹ + n₂ * d₂⁻¹,
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, left_distrib, right_distrib, mul_inv_rev₀, d₁0, d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0]} },
  rw [← mul_assoc (d₂:α), mul_inv_cancel d₂0, one_mul,
      (nat.cast_commute _ _).eq], simp [d₁0, mul_assoc]
end

@[simp, norm_cast] theorem cast_neg : ∀ n, ((-n : ℚ) : α) = -n
| ⟨n, d, h, c⟩ := show (↑-n / d : α) = -(n / d),
  by rw [div_eq_mul_inv, div_eq_mul_inv, int.cast_neg, neg_mul_eq_neg_mul]

@[norm_cast] theorem cast_sub_of_ne_zero {m n : ℚ}
  (m0 : (m.denom : α) ≠ 0) (n0 : (n.denom : α) ≠ 0) : ((m - n : ℚ) : α) = m - n :=
have ((-n).denom : α) ≠ 0, by cases n; exact n0,
by simp [sub_eq_add_neg, (cast_add_of_ne_zero m0 this)]

@[norm_cast] theorem cast_mul_of_ne_zero : ∀ {m n : ℚ},
  (m.denom : α) ≠ 0 → (n.denom : α) ≠ 0 → ((m * n : ℚ) : α) = m * n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := λ (d₁0 : (d₁:α) ≠ 0) (d₂0 : (d₂:α) ≠ 0), begin
  have d₁0' : (d₁:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₁0; exact d₁0 rfl),
  have d₂0' : (d₂:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d₂0; exact d₂0 rfl),
  rw [num_denom', num_denom', mul_def d₁0' d₂0'],
  suffices : (n₁ * ((n₂ * d₂⁻¹) * d₁⁻¹) : α) = n₁ * (d₁⁻¹ * (n₂ * d₂⁻¹)),
  { rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, cast_mk_of_ne_zero],
    { simpa [division_def, mul_inv_rev₀, d₁0, d₂0, mul_assoc] },
    all_goals {simp [d₁0, d₂0]} },
  rw [(d₁.commute_cast (_:α)).inv_right₀.eq]
end

@[simp] theorem cast_inv_nat (n : ℕ) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
begin
  cases n, { simp },
  simp_rw [coe_nat_eq_mk, inv_def, mk, mk_nat, dif_neg n.succ_ne_zero, mk_pnat],
  simp [cast_def]
end

@[simp] theorem cast_inv_int (n : ℤ) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
begin
  cases n,
  { exact cast_inv_nat _ },
  { simp only [int.cast_neg_succ_of_nat, ← nat.cast_succ, cast_neg, inv_neg, cast_inv_nat] }
end

@[norm_cast] theorem cast_inv_of_ne_zero : ∀ {n : ℚ},
  (n.num : α) ≠ 0 → (n.denom : α) ≠ 0 → ((n⁻¹ : ℚ) : α) = n⁻¹
| ⟨n, d, h, c⟩ := λ (n0 : (n:α) ≠ 0) (d0 : (d:α) ≠ 0), begin
  have n0' : (n:ℤ) ≠ 0 := λ e, by rw e at n0; exact n0 rfl,
  have d0' : (d:ℤ) ≠ 0 := int.coe_nat_ne_zero.2 (λ e, by rw e at d0; exact d0 rfl),
  rw [num_denom', inv_def],
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero, inv_div];
  simp [n0, d0]
end

@[norm_cast] theorem cast_div_of_ne_zero {m n : ℚ} (md : (m.denom : α) ≠ 0)
  (nn : (n.num : α) ≠ 0) (nd : (n.denom : α) ≠ 0) : ((m / n : ℚ) : α) = m / n :=
have (n⁻¹.denom : ℤ) ∣ n.num,
by conv in n⁻¹.denom { rw [←(@num_denom n), inv_def] };
   apply denom_dvd,
have (n⁻¹.denom : α) = 0 → (n.num : α) = 0, from
λ h, let ⟨k, e⟩ := this in
  by have := congr_arg (coe : ℤ → α) e;
     rwa [int.cast_mul, int.cast_coe_nat, h, zero_mul] at this,
by rw [division_def, cast_mul_of_ne_zero md (mt this nn), cast_inv_of_ne_zero nn nd, division_def]

@[simp, norm_cast] theorem cast_inj [char_zero α] : ∀ {m n : ℚ}, (m : α) = n ↔ m = n
| ⟨n₁, d₁, h₁, c₁⟩ ⟨n₂, d₂, h₂, c₂⟩ := begin
  refine ⟨λ h, _, congr_arg _⟩,
  have d₁0 : d₁ ≠ 0 := ne_of_gt h₁,
  have d₂0 : d₂ ≠ 0 := ne_of_gt h₂,
  have d₁a : (d₁:α) ≠ 0 := nat.cast_ne_zero.2 d₁0,
  have d₂a : (d₂:α) ≠ 0 := nat.cast_ne_zero.2 d₂0,
  rw [num_denom', num_denom'] at h ⊢,
  rw [cast_mk_of_ne_zero, cast_mk_of_ne_zero] at h; simp [d₁0, d₂0] at h ⊢,
  rwa [eq_div_iff_mul_eq d₂a, division_def, mul_assoc, (d₁.cast_commute (d₂:α)).inv_left₀.eq,
    ← mul_assoc, ← division_def, eq_comm, eq_div_iff_mul_eq d₁a, eq_comm,
    ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_coe_nat, ← int.cast_mul,
    int.cast_inj, ← mk_eq (int.coe_nat_ne_zero.2 d₁0) (int.coe_nat_ne_zero.2 d₂0)] at h
end

theorem cast_injective [char_zero α] : function.injective (coe : ℚ → α)
| m n := cast_inj.1

@[simp] theorem cast_eq_zero [char_zero α] {n : ℚ} : (n : α) = 0 ↔ n = 0 :=
by rw [← cast_zero, cast_inj]

theorem cast_ne_zero [char_zero α] {n : ℚ} : (n : α) ≠ 0 ↔ n ≠ 0 :=
not_congr cast_eq_zero

@[simp, norm_cast] theorem cast_add [char_zero α] (m n) :
  ((m + n : ℚ) : α) = m + n :=
cast_add_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp, norm_cast] theorem cast_sub [char_zero α] (m n) :
  ((m - n : ℚ) : α) = m - n :=
cast_sub_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp, norm_cast] theorem cast_mul [char_zero α] (m n) :
  ((m * n : ℚ) : α) = m * n :=
cast_mul_of_ne_zero (nat.cast_ne_zero.2 $ ne_of_gt m.pos) (nat.cast_ne_zero.2 $ ne_of_gt n.pos)

@[simp, norm_cast] theorem cast_bit0 [char_zero α] (n : ℚ) :
  ((bit0 n : ℚ) : α) = bit0 n :=
cast_add _ _

@[simp, norm_cast] theorem cast_bit1 [char_zero α] (n : ℚ) :
  ((bit1 n : ℚ) : α) = bit1 n :=
by rw [bit1, cast_add, cast_one, cast_bit0]; refl

variable (α)

/-- Coercion `ℚ → α` as a `ring_hom`. -/
def cast_hom [char_zero α] : ℚ →+* α := ⟨coe, cast_one, cast_mul, cast_zero, cast_add⟩

variable {α}

@[simp] lemma coe_cast_hom [char_zero α] : ⇑(cast_hom α) = coe := rfl

@[simp, norm_cast] theorem cast_inv [char_zero α] (n) : ((n⁻¹ : ℚ) : α) = n⁻¹ :=
(cast_hom α).map_inv _

@[simp, norm_cast] theorem cast_div [char_zero α] (m n) :
  ((m / n : ℚ) : α) = m / n :=
(cast_hom α).map_div _ _

@[norm_cast] theorem cast_mk [char_zero α] (a b : ℤ) : ((a /. b) : α) = a / b :=
by simp only [mk_eq_div, cast_div, cast_coe_int]

@[simp, norm_cast] theorem cast_pow [char_zero α] (q) (k : ℕ) :
  ((q ^ k : ℚ) : α) = q ^ k :=
(cast_hom α).map_pow q k

end with_div_ring

@[simp, norm_cast] theorem cast_nonneg [linear_ordered_field α] : ∀ {n : ℚ}, 0 ≤ (n : α) ↔ 0 ≤ n
| ⟨n, d, h, c⟩ :=
  by { rw [num_denom', cast_mk, mk_eq_div, div_nonneg_iff, div_nonneg_iff], norm_cast }

@[simp, norm_cast] theorem cast_le [linear_ordered_field α] {m n : ℚ} : (m : α) ≤ n ↔ m ≤ n :=
by rw [← sub_nonneg, ← cast_sub, cast_nonneg, sub_nonneg]

@[simp, norm_cast] theorem cast_lt [linear_ordered_field α] {m n : ℚ} : (m : α) < n ↔ m < n :=
by simpa [-cast_le] using not_congr (@cast_le α _ n m)

@[simp] theorem cast_nonpos [linear_ordered_field α] {n : ℚ} : (n : α) ≤ 0 ↔ n ≤ 0 :=
by rw [← cast_zero, cast_le]

@[simp] theorem cast_pos [linear_ordered_field α] {n : ℚ} : (0 : α) < n ↔ 0 < n :=
by rw [← cast_zero, cast_lt]

@[simp] theorem cast_lt_zero [linear_ordered_field α] {n : ℚ} : (n : α) < 0 ↔ n < 0 :=
by rw [← cast_zero, cast_lt]

@[simp, norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n
| ⟨n, d, h, c⟩ := by rw [num_denom', cast_mk, mk_eq_div]

@[simp, norm_cast] theorem cast_min [linear_ordered_field α] {a b : ℚ} :
  (↑(min a b) : α) = min a b :=
by by_cases a ≤ b; simp [h, min_def]

@[simp, norm_cast] theorem cast_max [linear_ordered_field α] {a b : ℚ} :
  (↑(max a b) : α) = max a b :=
by by_cases b ≤ a; simp [h, max_def]

@[simp, norm_cast] theorem cast_abs [linear_ordered_field α] {q : ℚ} :
  ((|q| : ℚ) : α) = |q| :=
by simp [abs_eq_max_neg]

end rat

open rat ring_hom

lemma ring_hom.eq_rat_cast {k} [division_ring k] (f : ℚ →+* k) (r : ℚ) : f r = r :=
calc f r = f (r.1 / r.2) : by rw [← int.cast_coe_nat, ← mk_eq_div, num_denom]
     ... = f r.1 / f r.2 : f.map_div _ _
     ... = r.1 / r.2     : by rw [map_nat_cast, map_int_cast]

-- This seems to be true for a `[char_p k]` too because `k'` must have the same characteristic
-- but the proof would be much longer
lemma ring_hom.map_rat_cast {k k'} [division_ring k] [char_zero k] [division_ring k']
  (f : k →+* k') (r : ℚ) :
  f r = r :=
(f.comp (cast_hom k)).eq_rat_cast r

lemma ring_hom.ext_rat {R : Type*} [semiring R] (f g : ℚ →+* R) : f = g :=
begin
  ext r,
  refine rat.num_denom_cases_on' r _,
  intros a b b0,
  let φ : ℤ →+* R := f.comp (int.cast_ring_hom ℚ),
  let ψ : ℤ →+* R := g.comp (int.cast_ring_hom ℚ),
  rw [rat.mk_eq_div, int.cast_coe_nat],
  have b0' : (b:ℚ) ≠ 0 := nat.cast_ne_zero.2 b0,
  have : ∀ n : ℤ, f n = g n := λ n, show φ n = ψ n, by rw [φ.ext_int ψ],
  calc f (a * b⁻¹)
      = f a * f b⁻¹ * (g (b:ℤ) * g b⁻¹) :
        by rw [int.cast_coe_nat, ← g.map_mul, mul_inv_cancel b0', g.map_one, mul_one, f.map_mul]
  ... = g a * f b⁻¹ * (f (b:ℤ) * g b⁻¹) : by rw [this a, ← this b]
  ... = g (a * b⁻¹) :
        by rw [int.cast_coe_nat, mul_assoc, ← mul_assoc (f b⁻¹),
              ← f.map_mul, inv_mul_cancel b0', f.map_one, one_mul, g.map_mul]
end

instance rat.subsingleton_ring_hom {R : Type*} [semiring R] : subsingleton (ℚ →+* R) :=
⟨ring_hom.ext_rat⟩

namespace monoid_with_zero_hom

variables {M : Type*} [group_with_zero M]

/-- If `f` and `g` agree on the integers then they are equal `φ`.

See note [partially-applied ext lemmas] for why `comp` is used here. -/
@[ext]
theorem ext_rat {f g : monoid_with_zero_hom ℚ M}
  (same_on_int : f.comp (int.cast_ring_hom ℚ).to_monoid_with_zero_hom =
    g.comp (int.cast_ring_hom ℚ).to_monoid_with_zero_hom) : f = g :=
begin
  have same_on_int' : ∀ k : ℤ, f k = g k := congr_fun same_on_int,
  ext x,
  rw [← @rat.num_denom x, rat.mk_eq_div, f.map_div, g.map_div,
    same_on_int' x.num, same_on_int' x.denom],
end

/-- Positive integer values of a morphism `φ` and its value on `-1` completely determine `φ`. -/
theorem ext_rat_on_pnat {f g : monoid_with_zero_hom ℚ M}
  (same_on_neg_one : f (-1) = g (-1)) (same_on_pnat : ∀ n : ℕ, 0 < n → f n = g n) : f = g :=
ext_rat $ ext_int' (by simpa) ‹_›

end monoid_with_zero_hom


import Cat.Fam.Dual

/-! # Useful definitions -/

namespace Cat

/-! ## Epimorphisms

A morphism `f : α ↠ β` is *epi* iff for any two morphisms `g₁ g₂ : β ↠ γ`, we have
`g₁∘f ≈ g₂∘f → g₁ ≈ g₂`.
-/
section epi
  variable
    {ℂ : Fam.Cat}
    {α β : ℂ.Obj}

  @[simp]
  abbrev Fam.Cat.Epic.law'
    (ℂ : Cat)
    {α β : ℂ.Obj}
    (f : α ↠ β)
  : Prop :=
    {γ : ℂ.Obj}
    → (g₁ g₂ : β ↠ γ)
    → (g₁ ⊚ f) ≈ (g₂ ⊚ f)
    → g₁ ≈ g₂

  class Fam.Cat.Epic
    (f : α ↠ β)
  where
    law : Epic.law' ℂ f

  /-- `True` iff `f` is epic. -/
  def Fam.Cat.isEpic
    (f : α ↠ β)
    [Epic f]
  : Prop :=
    true
end epi

/-! ## Monomorphisms

A morphism `f : β → γ` is *monic* iff for any two morphisms `g₁ g₂ : α → β`, we have
`f∘g₁ ≈ f∘g₂ → g₁ ≈ g₂`.
-/
section monic
  variable
    {ℂ : Fam.Cat}
    {β γ : ℂ.Obj}

  @[simp]
  abbrev Fam.Cat.Monic.law'
    (ℂ : Fam.Cat)
    {β γ : ℂ.Obj}
    (f : β ↠ γ)
  : Prop :=
    {α : ℂ.Obj}
    → (g₁ g₂ : α ↠ β)
    → f ⊚ g₁ ≈ f ⊚ g₂
    → g₁ ≈ g₂

  class Fam.Cat.Monic
    (f : α ↠ β)
  : Type where
    law : Monic.law' ℂ f

  /-- `True` iff `f` is monic. -/
  def Fam.Cat.isMonic
    (f : α ↠ β)
    [Monic f]
  : Prop :=
    true
end monic

/-! ## Isomorphisms

A morphism `f : α → β` is *iso* iff there is a morphism `f⁻¹ : β → α` such that `f⁻¹ ∘ f ≈ id' β`
and `f ∘ f⁻¹ ≈ id' α`.
-/
section iso
  variable
    {ℂ : Fam.Cat}
    {α β : ℂ.Obj}

  -- @[simp]
  -- abbrev Fam.Cat.Iso.law'
  --   (f : α ↠ β)
  --   (g : β ↠ α)
  -- : Prop :=
  --   g ⊚ f ≈ ℂ.id

  class Fam.Cat.Iso
    (f : α ↠ β)
  where
    inv :
      β ↠ α
    law_left :
      f ⊚ inv ≈ ℂ.id
    law_right :
      inv ⊚ f ≈ ℂ.id

  abbrev Fam.Cat.isoInv
    (f : α ↠ β)
    [inst : Iso f]
  : β ↠ α :=
    inst.inv

  /-- Turns a `Iso f` into a `Iso inv`. -/
  instance instIsoSelfInv
    (f : α ↠ β)
    [inst : Fam.Cat.Iso f]
  : Fam.Cat.Iso (ℂ.isoInv f) where
    inv :=
      f
    law_left :=
      inst.law_right
    law_right :=
      inst.law_left

  /-- `True` iff `f` is iso. -/
  def Fam.Cat.isIso
    (f : α ↠ β)
    [Iso f]
  : Prop :=
    true
end iso

/-! Isomorphic objects (`≅`, `\~==`).

Two objects `α` and `β` are *isomorphic* if they are connected by an *iso*-arrow.
-/
section iso_obj
  variable
    {ℂ : Fam.Cat}
    {α β : ℂ.Obj}

  /-- Packages the isomorphism. -/
  class Fam.Cat.IsoObj
    (α β : ℂ.Obj)
  where rawMk ::
    iso : α ↠ β
    instIso : Iso iso

  /-- Bring `Iso i.iso` whenever we manipulate `i : IsoObj α β`. -/
  @[simp]
  instance instIso_of_IsoObj
    [inst : Fam.Cat.IsoObj α β]
  : Fam.Cat.Iso (inst.iso) :=
    inst.instIso

  abbrev Fam.Cat.IsoObj.mk
    (iso : α ↠ β)
    [instIso : Iso iso]
  : IsoObj α β :=
    ⟨iso, instIso⟩

  /-- `True` iff `α` and `β` are isomorphic. -/
  def Fam.Cat.isIsoObj
    (α β : ℂ.Obj)
    [IsoObj α β]
  : Prop :=
    true

  infix:10 " ≅ " =>
    Fam.Cat.IsoObj
end iso_obj

/-! ## Initial objects

An object `α` is *initial* iff for any `β` there exists a **unique** arrow in `α ↠ β`.
-/
section initial_obj
  variable
    {ℂ : Fam.Cat}

  class Fam.Cat.Initial
    (α : ℂ.Obj)
  where
    arrow {β : ℂ.Obj} :
      α ↠ β
    unique {β : ℂ.Obj} (f : α ↠ β) :
      arrow ≈ f

  /-- If `α` is initial, then any `α → α` is actually `id`. -/
  theorem Fam.Cat.Initial.equivId
    [instα : Initial α]
    (f : α ↠ α)
  : f ≈ ℂ.id :=
    let h₁ : f ≈ arrow :=
      instα.unique f
      |> Setoid.symm
    let h₂ : arrow ≈ ℂ.id :=
      instα.unique ℂ.id
    Setoid.trans h₁ h₂

  /-- `True` iff `α` is initial. -/
  def Fam.Cat.isInitial
    (α : ℂ.Obj)
    [Initial α]
  : Prop :=
    true
end initial_obj

/-! ## Terminal objects

An object `β` is *terminal* iff for any `α` there existst a **unique** arrow in `α ↠ β`.
-/
section terminal_obj
  variable
    {ℂ: Fam.Cat}

  class Fam.Cat.Terminal
    (β : ℂ.Obj)
  where
    arrow {α : ℂ.Obj} :
      α ↠ β
    unique {α : ℂ.Obj} (f : α ↠ β) :
      arrow ≈ f

  /-- If `α` is terminal, then any `α → α` is actually `id`. -/
  theorem Fam.Cat.Terminal.equivId
    [instα : Terminal α]
    (f : α ↠ α)
  : f ≈ ℂ.id :=
    let h₁ : f ≈ arrow :=
      instα.unique f
      |> Setoid.symm
    let h₂ : arrow ≈ ℂ.id :=
      instα.unique ℂ.id
    Setoid.trans h₁ h₂

  /-- `True` iff `β` is terminal. -/
  def Fam.Cat.isTerminal
    (β : ℂ.Obj)
    [Terminal β]
  : Prop :=
    true
end terminal_obj


example (p q : Prop) : p ∧ q → q ∧ p :=
begin
  intro h,
  cases h with hp hq,
  split,
  show q, from hq,
  show p, from hp,
end

example (p q : Prop) : p ∧ q → q ∧ p :=
begin
  intro h,
  cases h with hp hq,
  split,
  show p, from hp,
  show q, from hq
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.PostPort

universes u₁ u₂ u₃ v₁ v₂ v₃ u₄ v₄ u₅ v₅

namespace Mathlib

namespace category_theory

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simp] theorem whisker_left_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ⟶ H) (X : C) :
    nat_trans.app (whisker_left F α) X = nat_trans.app α (functor.obj F X) :=
  Eq.refl (nat_trans.app (whisker_left F α) X)

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
def whisker_right {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E]
    {G : C ⥤ D} {H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : G ⋙ F ⟶ H ⋙ F :=
  nat_trans.mk fun (X : C) => functor.map F (nat_trans.app α X)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_lift.obj F).obj G` is `F ⋙ G`, and
`(whiskering_lift.obj F).map α` is `whisker_left F α`.
-/
def whiskering_left (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃)
    [category E] : (C ⥤ D) ⥤ (D ⥤ E) ⥤ C ⥤ E :=
  functor.mk
    (fun (F : C ⥤ D) =>
      functor.mk (fun (G : D ⥤ E) => F ⋙ G) fun (G H : D ⥤ E) (α : G ⟶ H) => whisker_left F α)
    fun (F G : C ⥤ D) (τ : F ⟶ G) =>
      nat_trans.mk fun (H : D ⥤ E) => nat_trans.mk fun (c : C) => functor.map H (nat_trans.app τ c)

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simp] theorem whiskering_right_obj_map (C : Type u₁) [category C] (D : Type u₂) [category D]
    (E : Type u₃) [category E] (H : D ⥤ E) (_x : C ⥤ D) :
    ∀ (_x_1 : C ⥤ D) (α : _x ⟶ _x_1),
        functor.map (functor.obj (whiskering_right C D E) H) α = whisker_right α H :=
  fun (_x_1 : C ⥤ D) (α : _x ⟶ _x_1) =>
    Eq.refl (functor.map (functor.obj (whiskering_right C D E) H) α)

@[simp] theorem whisker_left_id {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D) {G : D ⥤ E} : whisker_left F (nat_trans.id G) = nat_trans.id (F ⋙ G) :=
  rfl

@[simp] theorem whisker_left_id' {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D) {G : D ⥤ E} : whisker_left F 𝟙 = 𝟙 :=
  rfl

@[simp] theorem whisker_right_id {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {G : C ⥤ D} (F : D ⥤ E) :
    whisker_right (nat_trans.id G) F = nat_trans.id (G ⋙ F) :=
  functor.map_id (functor.obj (whiskering_right C D E) F) G

@[simp] theorem whisker_right_id' {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {G : C ⥤ D} (F : D ⥤ E) : whisker_right 𝟙 F = 𝟙 :=
  functor.map_id (functor.obj (whiskering_right C D E) F) G

@[simp] theorem whisker_left_comp {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} {K : D ⥤ E} (α : G ⟶ H)
    (β : H ⟶ K) : whisker_left F (α ≫ β) = whisker_left F α ≫ whisker_left F β :=
  rfl

@[simp] theorem whisker_right_comp {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} {K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K)
    (F : D ⥤ E) : whisker_right (α ≫ β) F = whisker_right α F ≫ whisker_right β F :=
  functor.map_comp (functor.obj (whiskering_right C D E) F) α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ≅ H) : F ⋙ G ≅ F ⋙ H :=
  functor.map_iso (functor.obj (whiskering_left C D E) F) α

@[simp] theorem iso_whisker_left_hom {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ≅ H) :
    iso.hom (iso_whisker_left F α) = whisker_left F (iso.hom α) :=
  rfl

@[simp] theorem iso_whisker_left_inv {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ≅ H) :
    iso.inv (iso_whisker_left F α) = whisker_left F (iso.inv α) :=
  rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (G ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : G ⋙ F ≅ H ⋙ F :=
  functor.map_iso (functor.obj (whiskering_right C D E) F) α

@[simp] theorem iso_whisker_right_hom {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
    iso.hom (iso_whisker_right α F) = whisker_right (iso.hom α) F :=
  rfl

@[simp] theorem iso_whisker_right_inv {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
    iso.inv (iso_whisker_right α F) = whisker_right (iso.inv α) F :=
  rfl

protected instance is_iso_whisker_left {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] (F : C ⥤ D) {G : D ⥤ E} {H : D ⥤ E} (α : G ⟶ H) [is_iso α] :
    is_iso (whisker_left F α) :=
  is_iso.mk (iso.inv (iso_whisker_left F (as_iso α)))

protected instance is_iso_whisker_right {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {G : C ⥤ D} {H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] :
    is_iso (whisker_right α F) :=
  is_iso.mk (iso.inv (iso_whisker_right (as_iso α) F))

@[simp] theorem whisker_left_twice {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {B : Type u₄} [category B] (F : B ⥤ C) (G : C ⥤ D) {H : D ⥤ E}
    {K : D ⥤ E} (α : H ⟶ K) : whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
  rfl

@[simp] theorem whisker_right_twice {C : Type u₁} [category C] {D : Type u₂} [category D]
    {E : Type u₃} [category E] {B : Type u₄} [category B] {H : B ⥤ C} {K : B ⥤ C} (F : C ⥤ D)
    (G : D ⥤ E) (α : H ⟶ K) : whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
  rfl

theorem whisker_right_left {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃}
    [category E] {B : Type u₄} [category B] (F : B ⥤ C) {G : C ⥤ D} {H : C ⥤ D} (α : G ⟶ H)
    (K : D ⥤ E) : whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
  rfl

namespace functor

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simp] theorem left_unitor_hom_app {A : Type u₁} [category A] {B : Type u₂} [category B]
    (F : A ⥤ B) (X : A) : nat_trans.app (iso.hom (left_unitor F)) X = 𝟙 :=
  Eq.refl (nat_trans.app (iso.hom (left_unitor F)) X)

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simp] theorem right_unitor_hom_app {A : Type u₁} [category A] {B : Type u₂} [category B]
    (F : A ⥤ B) (X : A) : nat_trans.app (iso.hom (right_unitor F)) X = 𝟙 :=
  Eq.refl (nat_trans.app (iso.hom (right_unitor F)) X)

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simp] theorem associator_inv_app {A : Type u₁} [category A] {B : Type u₂} [category B]
    {C : Type u₃} [category C] {D : Type u₄} [category D] (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D)
    (_x : A) : nat_trans.app (iso.inv (associator F G H)) _x = 𝟙 :=
  Eq.refl (nat_trans.app (iso.inv (associator F G H)) _x)

theorem triangle {A : Type u₁} [category A] {B : Type u₂} [category B] {C : Type u₃} [category C]
    (F : A ⥤ B) (G : B ⥤ C) :
    iso.hom (associator F 𝟭 G) ≫ whisker_left F (iso.hom (left_unitor G)) =
        whisker_right (iso.hom (right_unitor F)) G :=
  sorry

theorem pentagon {A : Type u₁} [category A] {B : Type u₂} [category B] {C : Type u₃} [category C]
    {D : Type u₄} [category D] {E : Type u₅} [category E] (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D)
    (K : D ⥤ E) :
    whisker_right (iso.hom (associator F G H)) K ≫
          iso.hom (associator F (G ⋙ H) K) ≫ whisker_left F (iso.hom (associator G H K)) =
        iso.hom (associator (F ⋙ G) H K) ≫ iso.hom (associator F G (H ⋙ K)) :=
  sorry

end Mathlib


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

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

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

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

namespace ctop
section
variables (F : ctop α σ)

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

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

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

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

end

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

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

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

end ctop

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

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

namespace ctop.realizer

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

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

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

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

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

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

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

variable [topological_space α]

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

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

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

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

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

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

end ctop.realizer

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

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

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

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


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.additive
import tactic.abel

/-!
# Chain homotopies

We define chain homotopies, and prove that homotopic chain maps induce the same map on homology.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.limits homological_complex

variables {ι : Type*}
variables {V : Type u} [category.{v} V] [preadditive V]

variables {c : complex_shape ι} {C D E : homological_complex V c}
variables (f g : C ⟶ D) (h k : D ⟶ E) (i : ι)

section

/-- The composition of `C.d i i' ≫ f i' i` if there is some `i'` coming after `i`,
and `0` otherwise. -/
def d_next (i : ι) : (Π i j, C.X i ⟶ D.X j) →+ (C.X i ⟶ D.X i) :=
add_monoid_hom.mk' (λ f, C.d i (c.next i) ≫ f (c.next i) i) $
λ f g, preadditive.comp_add _ _ _ _ _ _

/-- `f i' i` if `i'` comes after `i`, and 0 if there's no such `i'`.
Hopefully there won't be much need for this, except in `d_next_eq_d_from_from_next`
to see that `d_next` factors through `C.d_from i`. -/
def from_next (i : ι) : (Π i j, C.X i ⟶ D.X j) →+ (C.X_next i ⟶ D.X i) :=
add_monoid_hom.mk' (λ f, f (c.next i) i) $ λ f g, rfl

@[simp]
lemma d_next_eq_d_from_from_next (f : Π i j, C.X i ⟶ D.X j) (i : ι) :
  d_next i f = C.d_from i ≫ from_next i f := rfl

lemma d_next_eq (f : Π i j, C.X i ⟶ D.X j) {i i' : ι} (w : c.rel i i') :
  d_next i f = C.d i i' ≫ f i' i :=
by { obtain rfl := c.next_eq' w, refl }

@[simp] lemma d_next_comp_left (f : C ⟶ D) (g : Π i j, D.X i ⟶ E.X j) (i : ι) :
  d_next i (λ i j, f.f i ≫ g i j) = f.f i ≫ d_next i g :=
(f.comm_assoc _ _ _).symm

@[simp] lemma d_next_comp_right (f : Π i j, C.X i ⟶ D.X j) (g : D ⟶ E) (i : ι) :
  d_next i (λ i j, f i j ≫ g.f j) = d_next i f ≫ g.f i :=
(category.assoc _ _ _).symm

/-- The composition of `f j j' ≫ D.d j' j` if there is some `j'` coming before `j`,
and `0` otherwise. -/
def prev_d (j : ι) : (Π i j, C.X i ⟶ D.X j) →+ (C.X j ⟶ D.X j) :=
add_monoid_hom.mk' (λ f, f j (c.prev j) ≫ D.d (c.prev j) j) $
λ f g, preadditive.add_comp _ _ _ _ _ _

/-- `f j j'` if `j'` comes after `j`, and 0 if there's no such `j'`.
Hopefully there won't be much need for this, except in `d_next_eq_d_from_from_next`
to see that `d_next` factors through `C.d_from i`. -/
def to_prev (j : ι) : (Π i j, C.X i ⟶ D.X j) →+ (C.X j ⟶ D.X_prev j) :=
add_monoid_hom.mk' (λ f, f j (c.prev j)) $ λ f g, rfl

@[simp]
lemma prev_d_eq_to_prev_d_to (f : Π i j, C.X i ⟶ D.X j) (j : ι) :
  prev_d j f = to_prev j f ≫ D.d_to j := rfl

lemma prev_d_eq (f : Π i j, C.X i ⟶ D.X j) {j j' : ι} (w : c.rel j' j) :
  prev_d j f = f j j' ≫ D.d j' j :=
by { obtain rfl := c.prev_eq' w, refl }

@[simp] lemma prev_d_comp_left (f : C ⟶ D) (g : Π i j, D.X i ⟶ E.X j) (j : ι) :
  prev_d j (λ i j, f.f i ≫ g i j) = f.f j ≫ prev_d j g :=
category.assoc _ _ _

@[simp] lemma prev_d_comp_right (f : Π i j, C.X i ⟶ D.X j) (g : D ⟶ E) (j : ι) :
  prev_d j (λ i j, f i j ≫ g.f j) = prev_d j f ≫ g.f j :=
by { dsimp [prev_d], simp only [category.assoc, g.comm] }

lemma d_next_nat (C D : chain_complex V ℕ) (i : ℕ) (f : Π i j, C.X i ⟶ D.X j) :
  d_next i f = C.d i (i-1) ≫ f (i-1) i :=
begin
  dsimp [d_next],
  cases i,
  { simp only [shape, chain_complex.next_nat_zero, complex_shape.down_rel,
      nat.one_ne_zero, not_false_iff, zero_comp], },
  { dsimp only [nat.succ_eq_add_one],
    have : (complex_shape.down ℕ).next (i + 1) = i + 1 - 1,
    { rw chain_complex.next_nat_succ, refl },
    congr' 2, }
end

lemma prev_d_nat (C D : cochain_complex V ℕ) (i : ℕ) (f : Π i j, C.X i ⟶ D.X j) :
  prev_d i f = f i (i-1) ≫ D.d (i-1) i :=
begin
  dsimp [prev_d],
  cases i,
  { simp only [shape, cochain_complex.prev_nat_zero, complex_shape.up_rel,
      nat.one_ne_zero, not_false_iff, comp_zero]},
  { dsimp only [nat.succ_eq_add_one],
    have : (complex_shape.up ℕ).prev (i + 1) = i + 1 - 1,
    { rw cochain_complex.prev_nat_succ, refl },
    congr' 2, },
end

/--
A homotopy `h` between chain maps `f` and `g` consists of components `h i j : C.X i ⟶ D.X j`
which are zero unless `c.rel j i`, satisfying the homotopy condition.
-/
@[ext, nolint has_nonempty_instance]
structure homotopy (f g : C ⟶ D) :=
(hom : Π i j, C.X i ⟶ D.X j)
(zero' : ∀ i j, ¬ c.rel j i → hom i j = 0 . obviously)
(comm : ∀ i, f.f i = d_next i hom + prev_d i hom + g.f i . obviously')

variables {f g}
namespace homotopy

restate_axiom homotopy.zero'

/--
`f` is homotopic to `g` iff `f - g` is homotopic to `0`.
-/
def equiv_sub_zero : homotopy f g ≃ homotopy (f - g) 0 :=
{ to_fun := λ h,
  { hom := λ i j, h.hom i j,
    zero' := λ i j w, h.zero _ _ w,
    comm := λ i, by simp [h.comm] },
  inv_fun := λ h,
  { hom := λ i j, h.hom i j,
    zero' := λ i j w, h.zero _ _ w,
    comm := λ i, by simpa [sub_eq_iff_eq_add] using h.comm i },
  left_inv := by tidy,
  right_inv := by tidy, }

/-- Equal chain maps are homotopic. -/
@[simps]
def of_eq (h : f = g) : homotopy f g :=
{ hom := 0,
  zero' := λ _ _ _, rfl,
  comm := λ _, by simp only [add_monoid_hom.map_zero, zero_add, h] }

/-- Every chain map is homotopic to itself. -/
@[simps, refl]
def refl (f : C ⟶ D) : homotopy f f :=
of_eq (rfl : f = f)

/-- `f` is homotopic to `g` iff `g` is homotopic to `f`. -/
@[simps, symm]
def symm {f g : C ⟶ D} (h : homotopy f g) : homotopy g f :=
{ hom := -h.hom,
  zero' := λ i j w, by rw [pi.neg_apply, pi.neg_apply, h.zero i j w, neg_zero],
  comm := λ i, by rw [add_monoid_hom.map_neg, add_monoid_hom.map_neg, h.comm, ← neg_add,
      ← add_assoc, neg_add_self, zero_add] }

/-- homotopy is a transitive relation. -/
@[simps, trans]
def trans {e f g : C ⟶ D} (h : homotopy e f) (k : homotopy f g) : homotopy e g :=
{ hom := h.hom + k.hom,
  zero' := λ i j w, by rw [pi.add_apply, pi.add_apply, h.zero i j w, k.zero i j w, zero_add],
  comm := λ i, by { rw [add_monoid_hom.map_add, add_monoid_hom.map_add, h.comm, k.comm], abel }, }

/-- the sum of two homotopies is a homotopy between the sum of the respective morphisms. -/
@[simps]
def add {f₁ g₁ f₂ g₂ : C ⟶ D}
  (h₁ : homotopy f₁ g₁) (h₂ : homotopy f₂ g₂) : homotopy (f₁+f₂) (g₁+g₂) :=
{ hom := h₁.hom + h₂.hom,
  zero' := λ i j hij, by
    rw [pi.add_apply, pi.add_apply, h₁.zero' i j hij, h₂.zero' i j hij, add_zero],
  comm := λ i, by
    { simp only [homological_complex.add_f_apply, h₁.comm, h₂.comm,
        add_monoid_hom.map_add],
      abel, }, }

/-- homotopy is closed under composition (on the right) -/
@[simps]
def comp_right {e f : C ⟶ D} (h : homotopy e f) (g : D ⟶ E) : homotopy (e ≫ g) (f ≫ g) :=
{ hom := λ i j, h.hom i j ≫ g.f j,
  zero' := λ i j w, by rw [h.zero i j w, zero_comp],
  comm := λ i, by simp only [h.comm i, d_next_comp_right, preadditive.add_comp,
    prev_d_comp_right, comp_f], }

/-- homotopy is closed under composition (on the left) -/
@[simps]
def comp_left {f g : D ⟶ E} (h : homotopy f g) (e : C ⟶ D) : homotopy (e ≫ f) (e ≫ g) :=
{ hom := λ i j, e.f i ≫ h.hom i j,
  zero' := λ i j w, by rw [h.zero i j w, comp_zero],
  comm := λ i, by simp only [h.comm i, d_next_comp_left, preadditive.comp_add,
    prev_d_comp_left, comp_f], }

/-- homotopy is closed under composition -/
@[simps]
def comp {C₁ C₂ C₃ : homological_complex V c} {f₁ g₁ : C₁ ⟶ C₂} {f₂ g₂ : C₂ ⟶ C₃}
  (h₁ : homotopy f₁ g₁) (h₂ : homotopy f₂ g₂) : homotopy (f₁ ≫ f₂) (g₁ ≫ g₂) :=
(h₁.comp_right _).trans (h₂.comp_left _)

/-- a variant of `homotopy.comp_right` useful for dealing with homotopy equivalences. -/
@[simps]
def comp_right_id {f : C ⟶ C} (h : homotopy f (𝟙 C)) (g : C ⟶ D) : homotopy (f ≫ g) g :=
(h.comp_right g).trans (of_eq $ category.id_comp _)

/-- a variant of `homotopy.comp_left` useful for dealing with homotopy equivalences. -/
@[simps]
def comp_left_id {f : D ⟶ D} (h : homotopy f (𝟙 D)) (g : C ⟶ D) : homotopy (g ≫ f) g :=
(h.comp_left g).trans (of_eq $ category.comp_id _)

/-!
Null homotopic maps can be constructed using the formula `hd+dh`. We show that
these morphisms are homotopic to `0` and provide some convenient simplification
lemmas that give a degreewise description of `hd+dh`, depending on whether we have
two differentials going to and from a certain degree, only one, or none.
-/

/-- The null homotopic map associated to a family `hom` of morphisms `C_i ⟶ D_j`.
This is the same datum as for the field `hom` in the structure `homotopy`. For
this definition, we do not need the field `zero` of that structure
as this definition uses only the maps `C_i ⟶ C_j` when `c.rel j i`. -/
def null_homotopic_map (hom : Π i j, C.X i ⟶ D.X j) : C ⟶ D :=
{ f      := λ i, d_next i hom + prev_d i hom,
  comm'  := λ i j hij,
  begin
    have eq1 : prev_d i hom ≫ D.d i j = 0,
    { simp only [prev_d, add_monoid_hom.mk'_apply, category.assoc, d_comp_d, comp_zero], },
    have eq2 : C.d i j ≫ d_next j hom = 0,
    { simp only [d_next, add_monoid_hom.mk'_apply, d_comp_d_assoc, zero_comp], },
    rw [d_next_eq hom hij, prev_d_eq hom hij, preadditive.comp_add, preadditive.add_comp,
      eq1, eq2, add_zero, zero_add, category.assoc],
  end }

/-- Variant of `null_homotopic_map` where the input consists only of the
relevant maps `C_i ⟶ D_j` such that `c.rel j i`. -/
def null_homotopic_map' (h : Π i j, c.rel j i → (C.X i ⟶ D.X j)) : C ⟶ D :=
null_homotopic_map (λ i j, dite (c.rel j i) (h i j) (λ _, 0))

/-- Compatibility of `null_homotopic_map` with the postcomposition by a morphism
of complexes. -/
lemma null_homotopic_map_comp (hom : Π i j, C.X i ⟶ D.X j) (g : D ⟶ E) :
null_homotopic_map hom ≫ g = null_homotopic_map (λ i j, hom i j ≫ g.f j) :=
begin
  ext n,
  dsimp [null_homotopic_map, from_next, to_prev, add_monoid_hom.mk'_apply],
  simp only [preadditive.add_comp, category.assoc, g.comm],
end

/-- Compatibility of `null_homotopic_map'` with the postcomposition by a morphism
of complexes. -/
lemma null_homotopic_map'_comp (hom : Π i j, c.rel j i → (C.X i ⟶ D.X j)) (g : D ⟶ E) :
null_homotopic_map' hom ≫ g = null_homotopic_map' (λ i j hij, hom i j hij ≫ g.f j) :=
begin
  ext n,
  erw null_homotopic_map_comp,
  congr',
  ext i j,
  split_ifs,
  { refl, },
  { rw zero_comp, },
end

/-- Compatibility of `null_homotopic_map` with the precomposition by a morphism
of complexes. -/
lemma comp_null_homotopic_map (f : C ⟶ D) (hom : Π i j, D.X i ⟶ E.X j) :
f ≫ null_homotopic_map hom = null_homotopic_map (λ i j, f.f i ≫ hom i j) :=
begin
  ext n,
  dsimp [null_homotopic_map, from_next, to_prev, add_monoid_hom.mk'_apply],
  simp only [preadditive.comp_add, category.assoc, f.comm_assoc],
end

/-- Compatibility of `null_homotopic_map'` with the precomposition by a morphism
of complexes. -/
lemma comp_null_homotopic_map' (f : C ⟶ D) (hom : Π i j, c.rel j i → (D.X i ⟶ E.X j)) :
f ≫ null_homotopic_map' hom = null_homotopic_map' (λ i j hij, f.f i ≫ hom i j hij) :=
begin
  ext n,
  erw comp_null_homotopic_map,
  congr',
  ext i j,
  split_ifs,
  { refl, },
  { rw comp_zero, },
end

/-- Compatibility of `null_homotopic_map` with the application of additive functors -/
lemma map_null_homotopic_map {W : Type*} [category W] [preadditive W]
  (G : V ⥤ W) [G.additive] (hom : Π i j, C.X i ⟶ D.X j) :
  (G.map_homological_complex c).map (null_homotopic_map hom) =
  null_homotopic_map (λ i j, G.map (hom i j)) :=
begin
  ext i,
  dsimp [null_homotopic_map, d_next, prev_d],
  simp only [G.map_comp, functor.map_add],
end

/-- Compatibility of `null_homotopic_map'` with the application of additive functors -/
lemma map_null_homotopic_map' {W : Type*} [category W] [preadditive W]
  (G : V ⥤ W) [G.additive] (hom : Π i j, c.rel j i → (C.X i ⟶ D.X j)) :
  (G.map_homological_complex c).map (null_homotopic_map' hom) =
  null_homotopic_map' (λ i j hij, G.map (hom i j hij)) :=
begin
  ext n,
  erw map_null_homotopic_map,
  congr',
  ext i j,
  split_ifs,
  { refl, },
  { rw G.map_zero, }
end

/-- Tautological construction of the `homotopy` to zero for maps constructed by
`null_homotopic_map`, at least when we have the `zero'` condition. -/
@[simps]
def null_homotopy (hom : Π i j, C.X i ⟶ D.X j) (zero' : ∀ i j, ¬ c.rel j i → hom i j = 0) :
  homotopy (null_homotopic_map hom) 0 :=
{ hom := hom,
  zero' := zero',
  comm := by { intro i, rw [homological_complex.zero_f_apply, add_zero], refl, }, }

/-- Homotopy to zero for maps constructed with `null_homotopic_map'` -/
@[simps]
def null_homotopy' (h : Π i j, c.rel j i → (C.X i ⟶ D.X j)) :
  homotopy (null_homotopic_map' h) 0 :=
begin
  apply null_homotopy (λ i j, dite (c.rel j i) (h i j) (λ _, 0)),
  intros i j hij,
  dsimp,
  rw [dite_eq_right_iff],
  intro hij',
  exfalso,
  exact hij hij',
end

/-! This lemma and the following ones can be used in order to compute
the degreewise morphisms induced by the null homotopic maps constructed
with `null_homotopic_map` or `null_homotopic_map'` -/
@[simp]
lemma null_homotopic_map_f {k₂ k₁ k₀ : ι} (r₂₁ : c.rel k₂ k₁) (r₁₀ : c.rel k₁ k₀)
  (hom : Π i j, C.X i ⟶ D.X j) :
  (null_homotopic_map hom).f k₁ = C.d k₁ k₀ ≫ hom k₀ k₁ + hom k₁ k₂ ≫ D.d k₂ k₁ :=
by { dsimp only [null_homotopic_map], rw [d_next_eq hom r₁₀, prev_d_eq hom r₂₁], }

@[simp]
lemma null_homotopic_map'_f {k₂ k₁ k₀  : ι} (r₂₁ : c.rel k₂ k₁) (r₁₀ : c.rel k₁ k₀)
  (h : Π i j, c.rel j i → (C.X i ⟶ D.X j)) :
  (null_homotopic_map' h).f k₁ = C.d k₁ k₀ ≫ h k₀ k₁ r₁₀ + h k₁ k₂ r₂₁ ≫ D.d k₂ k₁ :=
begin
  simp only [← null_homotopic_map'],
  rw null_homotopic_map_f r₂₁ r₁₀ (λ i j, dite (c.rel j i) (h i j) (λ _, 0)),
  dsimp,
  split_ifs,
  refl,
end

@[simp]
lemma null_homotopic_map_f_of_not_rel_left {k₁ k₀ : ι} (r₁₀ : c.rel k₁ k₀)
  (hk₀ : ∀ l : ι, ¬c.rel k₀ l)
  (hom : Π i j, C.X i ⟶ D.X j) :
  (null_homotopic_map hom).f k₀ = hom k₀ k₁ ≫ D.d k₁ k₀ :=
begin
  dsimp only [null_homotopic_map],
  rw [prev_d_eq hom r₁₀, d_next, add_monoid_hom.mk'_apply, C.shape, zero_comp, zero_add],
  exact hk₀ _
end

@[simp]
lemma null_homotopic_map'_f_of_not_rel_left {k₁ k₀ : ι} (r₁₀ : c.rel k₁ k₀)
  (hk₀ : ∀ l : ι, ¬c.rel k₀ l)
  (h : Π i j, c.rel j i → (C.X i ⟶ D.X j)) :
  (null_homotopic_map' h).f k₀ = h k₀ k₁ r₁₀ ≫ D.d k₁ k₀ :=
begin
  simp only [← null_homotopic_map'],
  rw null_homotopic_map_f_of_not_rel_left r₁₀ hk₀ (λ i j, dite (c.rel j i) (h i j) (λ _, 0)),
  dsimp,
  split_ifs,
  refl,
end

@[simp]
lemma null_homotopic_map_f_of_not_rel_right {k₁ k₀ : ι} (r₁₀ : c.rel k₁ k₀)
  (hk₁ : ∀ l : ι, ¬c.rel l k₁)
  (hom : Π i j, C.X i ⟶ D.X j) :
  (null_homotopic_map hom).f k₁ = C.d k₁ k₀ ≫ hom k₀ k₁ :=
begin
  dsimp only [null_homotopic_map],
  rw [d_next_eq hom r₁₀, prev_d, add_monoid_hom.mk'_apply, D.shape, comp_zero, add_zero],
  exact hk₁ _,
end

@[simp]
lemma null_homotopic_map'_f_of_not_rel_right {k₁ k₀ : ι} (r₁₀ : c.rel k₁ k₀)
  (hk₁ : ∀ l : ι, ¬c.rel l k₁)
  (h : Π i j, c.rel j i → (C.X i ⟶ D.X j)) :
  (null_homotopic_map' h).f k₁ = C.d k₁ k₀ ≫ h k₀ k₁ r₁₀ :=
begin
  simp only [← null_homotopic_map'],
  rw null_homotopic_map_f_of_not_rel_right r₁₀ hk₁ (λ i j, dite (c.rel j i) (h i j) (λ _, 0)),
  dsimp,
  split_ifs,
  refl,
end

@[simp]
lemma null_homotopic_map_f_eq_zero {k₀ : ι}
  (hk₀ : ∀ l : ι, ¬c.rel k₀ l) (hk₀' : ∀ l : ι, ¬c.rel l k₀)
  (hom : Π i j, C.X i ⟶ D.X j) :
  (null_homotopic_map hom).f k₀ = 0 :=
begin
  dsimp [null_homotopic_map, d_next, prev_d],
  rw [C.shape, D.shape, zero_comp, comp_zero, add_zero]; apply_assumption,
end

@[simp]
lemma null_homotopic_map'_f_eq_zero {k₀ : ι}
  (hk₀ : ∀ l : ι, ¬c.rel k₀ l) (hk₀' : ∀ l : ι, ¬c.rel l k₀)
  (h : Π i j, c.rel j i → (C.X i ⟶ D.X j)) :
  (null_homotopic_map' h).f k₀ = 0 :=
begin
  simp only [← null_homotopic_map'],
  exact null_homotopic_map_f_eq_zero hk₀ hk₀'
    (λ i j, dite (c.rel j i) (h i j) (λ _, 0)),
end

/-!
`homotopy.mk_inductive` allows us to build a homotopy of chain complexes inductively,
so that as we construct each component, we have available the previous two components,
and the fact that they satisfy the homotopy condition.

To simplify the situation, we only construct homotopies of the form `homotopy e 0`.
`homotopy.equiv_sub_zero` can provide the general case.

Notice however, that this construction does not have particularly good definitional properties:
we have to insert `eq_to_hom` in several places.
Hopefully this is okay in most applications, where we only need to have the existence of some
homotopy.
-/
section mk_inductive

variables {P Q : chain_complex V ℕ}

@[simp] lemma prev_d_chain_complex (f : Π i j, P.X i ⟶ Q.X j) (j : ℕ) :
  prev_d j f = f j (j+1) ≫ Q.d _ _ :=
begin
  dsimp [prev_d],
  have : (complex_shape.down ℕ).prev j = j + 1 := chain_complex.prev ℕ j,
  congr' 2,
end

@[simp] lemma d_next_succ_chain_complex (f : Π i j, P.X i ⟶ Q.X j) (i : ℕ) :
  d_next (i+1) f = P.d _ _ ≫ f i (i+1) :=
begin
  dsimp [d_next],
  have : (complex_shape.down ℕ).next (i + 1) = i := chain_complex.next_nat_succ _,
  congr' 2,
end

@[simp] lemma d_next_zero_chain_complex (f : Π i j, P.X i ⟶ Q.X j) :
  d_next 0 f = 0 :=
begin
  dsimp [d_next],
  rw [P.shape, zero_comp],
  rw chain_complex.next_nat_zero, dsimp, dec_trivial,
end

variables (e : P ⟶ Q)
  (zero : P.X 0 ⟶ Q.X 1)
  (comm_zero : e.f 0 = zero ≫ Q.d 1 0)
  (one : P.X 1 ⟶ Q.X 2)
  (comm_one : e.f 1 = P.d 1 0 ≫ zero + one ≫ Q.d 2 1)
  (succ : ∀ (n : ℕ)
    (p : Σ' (f : P.X n ⟶ Q.X (n+1)) (f' : P.X (n+1) ⟶ Q.X (n+2)),
      e.f (n+1) = P.d (n+1) n ≫ f + f' ≫ Q.d (n+2) (n+1)),
    Σ' f'' : P.X (n+2) ⟶ Q.X (n+3), e.f (n+2) = P.d (n+2) (n+1) ≫ p.2.1 + f'' ≫ Q.d (n+3) (n+2))

include comm_one comm_zero

/--
An auxiliary construction for `mk_inductive`.

Here we build by induction a family of diagrams,
but don't require at the type level that these successive diagrams actually agree.
They do in fact agree, and we then capture that at the type level (i.e. by constructing a homotopy)
in `mk_inductive`.

At this stage, we don't check the homotopy condition in degree 0,
because it "falls off the end", and is easier to treat using `X_next` and `X_prev`,
which we do in `mk_inductive_aux₂`.
-/
@[simp, nolint unused_arguments]
def mk_inductive_aux₁ :
  Π n, Σ' (f : P.X n ⟶ Q.X (n+1)) (f' : P.X (n+1) ⟶ Q.X (n+2)),
    e.f (n+1) = P.d (n+1) n ≫ f + f' ≫ Q.d (n+2) (n+1)
| 0 := ⟨zero, one, comm_one⟩
| 1 := ⟨one, (succ 0 ⟨zero, one, comm_one⟩).1, (succ 0 ⟨zero, one, comm_one⟩).2⟩
| (n+2) :=
  ⟨(mk_inductive_aux₁ (n+1)).2.1,
    (succ (n+1) (mk_inductive_aux₁ (n+1))).1,
    (succ (n+1) (mk_inductive_aux₁ (n+1))).2⟩

section

/--
An auxiliary construction for `mk_inductive`.
-/
@[simp]
def mk_inductive_aux₂ :
  Π n, Σ' (f : P.X_next n ⟶ Q.X n) (f' : P.X n ⟶ Q.X_prev n), e.f n = P.d_from n ≫ f + f' ≫ Q.d_to n
| 0 := ⟨0, zero ≫ (Q.X_prev_iso rfl).inv, by simpa using comm_zero⟩
| (n+1) := let I := mk_inductive_aux₁ e zero comm_zero one comm_one succ n in
  ⟨(P.X_next_iso rfl).hom ≫ I.1, I.2.1 ≫ (Q.X_prev_iso rfl).inv, by simpa using I.2.2⟩

lemma mk_inductive_aux₃ (i j : ℕ) (h : i+1 = j) :
  (mk_inductive_aux₂ e zero comm_zero one comm_one succ i).2.1 ≫ (Q.X_prev_iso h).hom
    = (P.X_next_iso h).inv ≫ (mk_inductive_aux₂ e zero comm_zero one comm_one succ j).1 :=
by subst j; rcases i with (_|_|i); { dsimp, simp, }

/--
A constructor for a `homotopy e 0`, for `e` a chain map between `ℕ`-indexed chain complexes,
working by induction.

You need to provide the components of the homotopy in degrees 0 and 1,
show that these satisfy the homotopy condition,
and then give a construction of each component,
and the fact that it satisfies the homotopy condition,
using as an inductive hypothesis the data and homotopy condition for the previous two components.
-/
def mk_inductive : homotopy e 0 :=
{ hom := λ i j, if h : i + 1 = j then
    (mk_inductive_aux₂ e zero comm_zero one comm_one succ i).2.1 ≫ (Q.X_prev_iso h).hom
  else
    0,
  zero' := λ i j w, by rwa dif_neg,
  comm := λ i, begin
    dsimp, simp only [add_zero],
    convert (mk_inductive_aux₂ e zero comm_zero one comm_one succ i).2.2,
    { cases i,
      { dsimp [from_next], rw dif_neg,
        simp only [chain_complex.next_nat_zero, nat.one_ne_zero, not_false_iff], },
      { dsimp [from_next], rw dif_pos, swap, { simp only [chain_complex.next_nat_succ] },
        have aux : (complex_shape.down ℕ).next i.succ = i := chain_complex.next_nat_succ i,
        rw mk_inductive_aux₃ e zero comm_zero one comm_one succ
          ((complex_shape.down ℕ).next i.succ) (i+1) (by rw aux),
        dsimp [X_next_iso], erw category.id_comp, } },
    { dsimp [to_prev], rw dif_pos, swap, { simp only [chain_complex.prev] },
      dsimp [X_prev_iso], erw category.comp_id, },
  end, }

end

end mk_inductive

/-!
`homotopy.mk_coinductive` allows us to build a homotopy of cochain complexes inductively,
so that as we construct each component, we have available the previous two components,
and the fact that they satisfy the homotopy condition.
-/
section mk_coinductive

variables {P Q : cochain_complex V ℕ}

@[simp] lemma d_next_cochain_complex (f : Π i j, P.X i ⟶ Q.X j) (j : ℕ) :
  d_next j f = P.d _ _ ≫ f (j+1) j :=
begin
  dsimp [d_next],
  have : (complex_shape.up ℕ).next j = j + 1 := cochain_complex.next ℕ j,
  congr' 2,
end

@[simp] lemma prev_d_succ_cochain_complex (f : Π i j, P.X i ⟶ Q.X j) (i : ℕ) :
  prev_d (i+1) f = f (i+1) _ ≫ Q.d i (i+1) :=
begin
  dsimp [prev_d],
  have : (complex_shape.up ℕ).prev (i+1) = i := cochain_complex.prev_nat_succ i,
  congr' 2,
end

@[simp] lemma prev_d_zero_cochain_complex (f : Π i j, P.X i ⟶ Q.X j) :
  prev_d 0 f = 0 :=
begin
  dsimp [prev_d],
  rw [Q.shape, comp_zero],
  rw [cochain_complex.prev_nat_zero], dsimp, dec_trivial,
end

variables (e : P ⟶ Q)
  (zero : P.X 1 ⟶ Q.X 0)
  (comm_zero : e.f 0 = P.d 0 1 ≫ zero)
  (one : P.X 2 ⟶ Q.X 1)
  (comm_one : e.f 1 = zero ≫ Q.d 0 1 + P.d 1 2 ≫ one)
  (succ : ∀ (n : ℕ)
    (p : Σ' (f : P.X (n+1) ⟶ Q.X n) (f' : P.X (n+2) ⟶ Q.X (n+1)),
      e.f (n+1) = f ≫ Q.d n (n+1) + P.d (n+1) (n+2) ≫ f'),
    Σ' f'' : P.X (n+3) ⟶ Q.X (n+2), e.f (n+2) = p.2.1 ≫ Q.d (n+1) (n+2) + P.d (n+2) (n+3) ≫ f'')

include comm_one comm_zero succ

/--
An auxiliary construction for `mk_coinductive`.

Here we build by induction a family of diagrams,
but don't require at the type level that these successive diagrams actually agree.
They do in fact agree, and we then capture that at the type level (i.e. by constructing a homotopy)
in `mk_coinductive`.

At this stage, we don't check the homotopy condition in degree 0,
because it "falls off the end", and is easier to treat using `X_next` and `X_prev`,
which we do in `mk_inductive_aux₂`.
-/
@[simp, nolint unused_arguments]
def mk_coinductive_aux₁ :
  Π n, Σ' (f : P.X (n+1) ⟶ Q.X n) (f' : P.X (n+2) ⟶ Q.X (n+1)),
    e.f (n+1) = f ≫ Q.d n (n+1) + P.d (n+1) (n+2) ≫ f'
| 0 := ⟨zero, one, comm_one⟩
| 1 := ⟨one, (succ 0 ⟨zero, one, comm_one⟩).1, (succ 0 ⟨zero, one, comm_one⟩).2⟩
| (n+2) :=
  ⟨(mk_coinductive_aux₁ (n+1)).2.1,
    (succ (n+1) (mk_coinductive_aux₁ (n+1))).1,
    (succ (n+1) (mk_coinductive_aux₁ (n+1))).2⟩

section

/--
An auxiliary construction for `mk_inductive`.
-/
@[simp]
def mk_coinductive_aux₂ :
  Π n, Σ' (f : P.X n ⟶ Q.X_prev n) (f' : P.X_next n ⟶ Q.X n),
    e.f n = f ≫ Q.d_to n + P.d_from n ≫ f'
| 0 := ⟨0, (P.X_next_iso rfl).hom ≫ zero, by simpa using comm_zero⟩
| (n+1) := let I := mk_coinductive_aux₁ e zero comm_zero one comm_one succ n in
  ⟨I.1 ≫ (Q.X_prev_iso rfl).inv, (P.X_next_iso rfl).hom ≫ I.2.1, by simpa using I.2.2⟩

lemma mk_coinductive_aux₃ (i j : ℕ) (h : i + 1 = j) :
  (P.X_next_iso h).inv ≫ (mk_coinductive_aux₂ e zero comm_zero one comm_one succ i).2.1
    = (mk_coinductive_aux₂ e zero comm_zero one comm_one succ j).1 ≫ (Q.X_prev_iso h).hom :=
by subst j; rcases i with (_|_|i); { dsimp, simp, }

/--
A constructor for a `homotopy e 0`, for `e` a chain map between `ℕ`-indexed cochain complexes,
working by induction.

You need to provide the components of the homotopy in degrees 0 and 1,
show that these satisfy the homotopy condition,
and then give a construction of each component,
and the fact that it satisfies the homotopy condition,
using as an inductive hypothesis the data and homotopy condition for the previous two components.
-/
def mk_coinductive : homotopy e 0 :=
{ hom := λ i j, if h : j + 1 = i then
    (P.X_next_iso h).inv ≫ (mk_coinductive_aux₂ e zero comm_zero one comm_one succ j).2.1
  else
    0,
  zero' := λ i j w, by rwa dif_neg,
  comm := λ i, begin
    dsimp,
    rw [add_zero, add_comm],
    convert (mk_coinductive_aux₂ e zero comm_zero one comm_one succ i).2.2 using 2,
    { cases i,
      { dsimp [to_prev], rw dif_neg,
        simp only [cochain_complex.prev_nat_zero, nat.one_ne_zero, not_false_iff], },
      { dsimp [to_prev], rw dif_pos, swap, { simp only [cochain_complex.prev_nat_succ] },
        have aux : (complex_shape.up ℕ).prev i.succ = i := cochain_complex.prev_nat_succ i,
        rw mk_coinductive_aux₃ e zero comm_zero one comm_one succ
          ((complex_shape.up ℕ).prev i.succ) (i+1) (by rw aux),
        dsimp [X_prev_iso], erw category.comp_id, } },
    { dsimp [from_next], rw dif_pos, swap, { simp only [cochain_complex.next] },
      dsimp [X_next_iso], erw category.id_comp, },
  end }

end

end mk_coinductive

end homotopy

/--
A homotopy equivalence between two chain complexes consists of a chain map each way,
and homotopies from the compositions to the identity chain maps.

Note that this contains data;
arguably it might be more useful for many applications if we truncated it to a Prop.
-/
structure homotopy_equiv (C D : homological_complex V c) :=
(hom : C ⟶ D)
(inv : D ⟶ C)
(homotopy_hom_inv_id : homotopy (hom ≫ inv) (𝟙 C))
(homotopy_inv_hom_id : homotopy (inv ≫ hom) (𝟙 D))

namespace homotopy_equiv

/-- Any complex is homotopy equivalent to itself. -/
@[refl] def refl (C : homological_complex V c) : homotopy_equiv C C :=
{ hom := 𝟙 C,
  inv := 𝟙 C,
  homotopy_hom_inv_id := by simp,
  homotopy_inv_hom_id := by simp, }

instance : inhabited (homotopy_equiv C C) := ⟨refl C⟩

/-- Being homotopy equivalent is a symmetric relation. -/
@[symm] def symm
  {C D : homological_complex V c} (f : homotopy_equiv C D) :
  homotopy_equiv D C :=
{ hom := f.inv,
  inv := f.hom,
  homotopy_hom_inv_id := f.homotopy_inv_hom_id,
  homotopy_inv_hom_id := f.homotopy_hom_inv_id, }

/-- Homotopy equivalence is a transitive relation. -/
@[trans] def trans
  {C D E : homological_complex V c} (f : homotopy_equiv C D) (g : homotopy_equiv D E) :
  homotopy_equiv C E :=
{ hom := f.hom ≫ g.hom,
  inv := g.inv ≫ f.inv,
  homotopy_hom_inv_id := by simpa using
    ((g.homotopy_hom_inv_id.comp_right_id f.inv).comp_left f.hom).trans f.homotopy_hom_inv_id,
  homotopy_inv_hom_id := by simpa using
    ((f.homotopy_inv_hom_id.comp_right_id g.hom).comp_left g.inv).trans g.homotopy_inv_hom_id, }

/-- An isomorphism of complexes induces a homotopy equivalence. -/
def of_iso {ι : Type*} {V : Type u} [category.{v} V] [preadditive V]
  {c : complex_shape ι} {C D : homological_complex V c} (f : C ≅ D) :
  homotopy_equiv C D :=
⟨f.hom, f.inv, homotopy.of_eq f.3, homotopy.of_eq f.4⟩

end homotopy_equiv

variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Homotopic maps induce the same map on homology.
-/
theorem homology_map_eq_of_homotopy (h : homotopy f g) (i : ι) :
  (homology_functor V c i).map f = (homology_functor V c i).map g :=
begin
  dsimp [homology_functor],
  apply eq_of_sub_eq_zero,
  ext,
  simp only [homology.π_map, comp_zero, preadditive.comp_sub],
  dsimp [kernel_subobject_map],
  simp_rw [h.comm i],
  simp only [zero_add, zero_comp, d_next_eq_d_from_from_next, kernel_subobject_arrow_comp_assoc,
    preadditive.comp_add],
  rw [←preadditive.sub_comp],
  simp only [category_theory.subobject.factor_thru_add_sub_factor_thru_right],
  erw [subobject.factor_thru_of_le (D.boundaries_le_cycles i)],
  { simp, },
  { rw [prev_d_eq_to_prev_d_to, ←category.assoc],
    apply image_subobject_factors_comp_self, },
end

/-- Homotopy equivalent complexes have isomorphic homologies. -/
def homology_obj_iso_of_homotopy_equiv (f : homotopy_equiv C D) (i : ι) :
  (homology_functor V c i).obj C ≅ (homology_functor V c i).obj D :=
{ hom := (homology_functor V c i).map f.hom,
  inv := (homology_functor V c i).map f.inv,
  hom_inv_id' := begin
    rw [←functor.map_comp, homology_map_eq_of_homotopy f.homotopy_hom_inv_id,
      category_theory.functor.map_id],
  end,
  inv_hom_id' := begin
    rw [←functor.map_comp, homology_map_eq_of_homotopy f.homotopy_inv_hom_id,
      category_theory.functor.map_id],
  end, }

end

namespace category_theory

variables {W : Type*} [category W] [preadditive W]

/-- An additive functor takes homotopies to homotopies. -/
@[simps]
def functor.map_homotopy (F : V ⥤ W) [F.additive] {f g : C ⟶ D} (h : homotopy f g) :
  homotopy ((F.map_homological_complex c).map f) ((F.map_homological_complex c).map g) :=
{ hom := λ i j, F.map (h.hom i j),
  zero' := λ i j w, by { rw [h.zero i j w, F.map_zero], },
  comm := λ i, begin
    dsimp [d_next, prev_d] at *,
    rw h.comm i,
    simp only [F.map_add, ← F.map_comp],
    refl
  end, }

/-- An additive functor preserves homotopy equivalences. -/
@[simps]
def functor.map_homotopy_equiv (F : V ⥤ W) [F.additive] (h : homotopy_equiv C D) :
  homotopy_equiv ((F.map_homological_complex c).obj C) ((F.map_homological_complex c).obj D) :=
{ hom := (F.map_homological_complex c).map h.hom,
  inv := (F.map_homological_complex c).map h.inv,
  homotopy_hom_inv_id := begin
    rw [←(F.map_homological_complex c).map_comp, ←(F.map_homological_complex c).map_id],
    exact F.map_homotopy h.homotopy_hom_inv_id,
  end,
  homotopy_inv_hom_id := begin
    rw [←(F.map_homological_complex c).map_comp, ←(F.map_homological_complex c).map_id],
    exact F.map_homotopy h.homotopy_inv_hom_id,
  end }

end category_theory