/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.equiv
import Mathlib.data.vector2
import Mathlib.PostPort

universes u u_1 w v

namespace Mathlib

namespace d_array

protected instance inhabited {n : ℕ} {α : fin n → Type u} [(i : fin n) → Inhabited (α i)] : Inhabited (d_array n α) :=
  { default := mk fun (_x : fin n) => Inhabited.default }

end d_array

namespace array

protected instance inhabited {n : ℕ} {α : Type u_1} [Inhabited α] : Inhabited (array n α) :=
  d_array.inhabited

theorem to_list_of_heq {n₁ : ℕ} {n₂ : ℕ} {α : Type u_1} {a₁ : array n₁ α} {a₂ : array n₂ α} (hn : n₁ = n₂) (ha : a₁ == a₂) : to_list a₁ = to_list a₂ := sorry

/- rev_list -/

theorem rev_list_reverse_aux {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (h : i ≤ n) (t : List α) : list.reverse_core (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) t =
  d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h t := sorry

@[simp] theorem rev_list_reverse {n : ℕ} {α : Type u} {a : array n α} : list.reverse (rev_list a) = to_list a :=
  rev_list_reverse_aux n d_array.iterate._proof_1 []

@[simp] theorem to_list_reverse {n : ℕ} {α : Type u} {a : array n α} : list.reverse (to_list a) = rev_list a := sorry

/- mem -/

theorem mem.def {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ a ↔ ∃ (i : fin n), read a i = v :=
  iff.rfl

theorem mem_rev_list_aux {n : ℕ} {α : Type u} {v : α} {a : array n α} {i : ℕ} (h : i ≤ n) : (∃ (j : fin n), ↑j < i ∧ read a j = v) ↔
  v ∈ d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h [] := sorry

@[simp] theorem mem_rev_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ rev_list a ↔ v ∈ a := sorry

@[simp] theorem mem_to_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ to_list a ↔ v ∈ a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (v ∈ to_list a ↔ v ∈ a)) (Eq.symm rev_list_reverse)))
    (iff.trans list.mem_reverse mem_rev_list)

/- foldr -/

theorem rev_list_foldr_aux {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α} {i : ℕ} (h : i ≤ n) : list.foldr f b (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) =
  d_array.iterate_aux a (fun (_x : fin n) => f) i h b := sorry

theorem rev_list_foldr {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α} : list.foldr f b (rev_list a) = foldl a b f :=
  rev_list_foldr_aux d_array.iterate._proof_1

/- foldl -/

theorem to_list_foldl {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : β → α → β} {a : array n α} : list.foldl f b (to_list a) = foldl a b (function.swap f) := sorry

/- length -/

theorem rev_list_length_aux {n : ℕ} {α : Type u} (a : array n α) (i : ℕ) (h : i ≤ n) : list.length (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) = i := sorry

@[simp] theorem rev_list_length {n : ℕ} {α : Type u} (a : array n α) : list.length (rev_list a) = n :=
  rev_list_length_aux a n d_array.iterate._proof_1

@[simp] theorem to_list_length {n : ℕ} {α : Type u} (a : array n α) : list.length (to_list a) = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (list.length (to_list a) = n)) (Eq.symm rev_list_reverse)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (list.length (list.reverse (rev_list a)) = n)) (list.length_reverse (rev_list a))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (list.length (rev_list a) = n)) (rev_list_length a))) (Eq.refl n)))

/- nth -/

theorem to_list_nth_le_aux {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (ih : i < n) (j : ℕ) {jh : j ≤ n} {t : List α} {h' : i < list.length (d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) j jh t)} : (∀ (k : ℕ) (tl : k < list.length t), j + k = i → list.nth_le t k tl = read a { val := i, property := ih }) →
  list.nth_le (d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) j jh t) i h' =
    read a { val := i, property := ih } := sorry

theorem to_list_nth_le {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (h : i < n) (h' : i < list.length (to_list a)) : list.nth_le (to_list a) i h' = read a { val := i, property := h } :=
  to_list_nth_le_aux i h n fun (k : ℕ) (tl : k < list.length []) => absurd tl (nat.not_lt_zero k)

@[simp] theorem to_list_nth_le' {n : ℕ} {α : Type u} (a : array n α) (i : fin n) (h' : ↑i < list.length (to_list a)) : list.nth_le (to_list a) (↑i) h' = read a i := sorry

theorem to_list_nth {n : ℕ} {α : Type u} {a : array n α} {i : ℕ} {v : α} : list.nth (to_list a) i = some v ↔ ∃ (h : i < n), read a { val := i, property := h } = v := sorry

theorem write_to_list {n : ℕ} {α : Type u} {a : array n α} {i : fin n} {v : α} : to_list (write a i v) = list.update_nth (to_list a) (↑i) v := sorry

/- enum -/

theorem mem_to_list_enum {n : ℕ} {α : Type u} {a : array n α} {i : ℕ} {v : α} : (i, v) ∈ list.enum (to_list a) ↔ ∃ (h : i < n), read a { val := i, property := h } = v := sorry

/- to_array -/

@[simp] theorem to_list_to_array {n : ℕ} {α : Type u} (a : array n α) : list.to_array (to_list a) == a := sorry

@[simp] theorem to_array_to_list {α : Type u} (l : List α) : to_list (list.to_array l) = l :=
  list.ext_le (to_list_length (list.to_array l))
    fun (n : ℕ) (h1 : n < list.length (to_list (list.to_array l))) (h2 : n < list.length l) => to_list_nth_le n h2 h1

/- push_back -/

theorem push_back_rev_list_aux {n : ℕ} {α : Type u} {v : α} {a : array n α} (i : ℕ) (h : i ≤ n + 1) (h' : i ≤ n) : d_array.iterate_aux (push_back a v) (fun (_x : fin (n + 1)) (_x : α) (_y : List α) => _x :: _y) i h [] =
  d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h' [] := sorry

@[simp] theorem push_back_rev_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : rev_list (push_back a v) = v :: rev_list a := sorry

@[simp] theorem push_back_to_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : to_list (push_back a v) = to_list a ++ [v] := sorry

/- foreach -/

@[simp] theorem read_foreach {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : fin n → α → β} {a : array n α} : read (foreach a f) i = f i (read a i) :=
  rfl

/- map -/

theorem read_map {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : α → β} {a : array n α} : read (map a f) i = f (read a i) :=
  read_foreach

/- map₂ -/

@[simp] theorem read_map₂ {n : ℕ} {α : Type u} {i : fin n} {f : α → α → α} {a₁ : array n α} {a₂ : array n α} : read (map₂ f a₁ a₂) i = f (read a₁ i) (read a₂ i) :=
  read_foreach

end array

namespace equiv

/-- The natural equivalence between length-`n` heterogeneous arrays
and dependent functions from `fin n`. -/
def d_array_equiv_fin {n : ℕ} (α : fin n → Type u_1) : d_array n α ≃ ((i : fin n) → α i) :=
  mk d_array.read d_array.mk sorry sorry

/-- The natural equivalence between length-`n` arrays and functions from `fin n`. -/
def array_equiv_fin (n : ℕ) (α : Type u_1) : array n α ≃ (fin n → α) :=
  d_array_equiv_fin fun (_x : fin n) => α

/-- The natural equivalence between length-`n` vectors and functions from `fin n`. -/
def vector_equiv_fin (α : Type u_1) (n : ℕ) : vector α n ≃ (fin n → α) :=
  mk vector.nth vector.of_fn vector.of_fn_nth sorry

/-- The natural equivalence between length-`n` vectors and length-`n` arrays. -/
def vector_equiv_array (α : Type u_1) (n : ℕ) : vector α n ≃ array n α :=
  equiv.trans (vector_equiv_fin α n) (equiv.symm (array_equiv_fin n α))

end equiv

namespace array

protected instance traversable {n : ℕ} : traversable (array n) :=
  equiv.traversable fun (α : Type u_1) => equiv.vector_equiv_array α n

protected instance is_lawful_traversable {n : ℕ} : is_lawful_traversable (array n) :=
  equiv.is_lawful_traversable fun (α : Type u_1) => equiv.vector_equiv_array α n


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Data.RBMap.WF

/-!
# Path operations; `modify` and `alter`

This develops the necessary theorems to construct the `modify` and `alter` functions on `RBSet`
using path operations for in-place modification of an `RBTree`.
-/

namespace Std

namespace RBNode
open RBColor

attribute [simp] Path.fill

/-! ## path balance -/

/-- Asserts that property `p` holds on the root of the tree, if any. -/
def OnRoot (p : α → Prop) : RBNode α → Prop
  | nil => True
  | node _ _ x _ => p x

/--
Auxiliary definition for `zoom_ins`: set the root of the tree to `v`, creating a node if necessary.
-/
def setRoot (v : α) : RBNode α → RBNode α
  | nil => node red nil v nil
  | node c a _ b => node c a v b

/--
Auxiliary definition for `zoom_ins`: set the root of the tree to `v`, creating a node if necessary.
-/
def delRoot : RBNode α → RBNode α
  | nil => nil
  | node _ a _ b => a.append b

namespace Path

/-- Same as `fill` but taking its arguments in a pair for easier composition with `zoom`. -/
@[inline] def fill' : RBNode α × Path α → RBNode α := fun (t, path) => path.fill t

theorem zoom_fill' (cut : α → Ordering) (t : RBNode α) (path : Path α) :
    fill' (zoom cut t path) = path.fill t := by
  induction t generalizing path with
  | nil => rfl
  | node _ _ _ _ iha ihb => unfold zoom; split <;> [apply iha, apply ihb, rfl]

theorem zoom_fill (H : zoom cut t path = (t', path')) : path.fill t = path'.fill t' :=
  (H ▸ zoom_fill' cut t path).symm

theorem insertNew_eq_insert (h : zoom (cmp v) t = (nil, path)) :
    path.insertNew v = (t.insert cmp v).setBlack :=
  insert_setBlack .. ▸ (zoom_ins h).symm

theorem zoom_del {t : RBNode α} :
    t.zoom cut path = (t', path') →
    path.del (t.del cut) (match t with | node c .. => c | _ => red) =
    path'.del t'.delRoot (match t' with | node c .. => c | _ => red) := by
  unfold RBNode.del; split <;> simp [zoom]
  · intro | rfl, rfl => rfl
  · next c a y b =>
    split
    · have IH := @zoom_del (t := a)
      match a with
      | nil => intro | rfl => rfl
      | node black .. | node red .. => apply IH
    · have IH := @zoom_del (t := b)
      match b with
      | nil => intro | rfl => rfl
      | node black .. | node red .. => apply IH
    · intro | rfl => rfl

variable (c₀ : RBColor) (n₀ : Nat) in
/--
The balance invariant for a path. `path.Balanced c₀ n₀ c n` means that `path` is a red-black tree
with balance invariant `c₀, n₀`, but it has a "hole" where a tree with balance invariant `c, n`
has been removed. The defining property is `Balanced.fill`: if `path.Balanced c₀ n₀ c n` and you
fill the hole with a tree satisfying `t.Balanced c n`, then `(path.fill t).Balanced c₀ n₀` .
-/
protected inductive Balanced : Path α → RBColor → Nat → Prop where
  /-- The root of the tree is `c₀, n₀`-balanced by assumption. -/
  | protected root : Path.root.Balanced c₀ n₀
  /-- Descend into the left subtree of a red node. -/
  | redL : Balanced y black n → parent.Balanced red n →
    (Path.left red parent v y).Balanced black n
  /-- Descend into the right subtree of a red node. -/
  | redR : Balanced x black n → parent.Balanced red n →
    (Path.right red x v parent).Balanced black n
  /-- Descend into the left subtree of a black node. -/
  | blackL : Balanced y c₂ n → parent.Balanced black (n + 1) →
    (Path.left black parent v y).Balanced c₁ n
  /-- Descend into the right subtree of a black node. -/
  | blackR : Balanced x c₁ n → parent.Balanced black (n + 1) →
    (Path.right black x v parent).Balanced c₂ n

/--
The defining property of a balanced path: If `path` is a `c₀,n₀` tree with a `c,n` hole,
then filling the hole with a `c,n` tree yields a `c₀,n₀` tree.
-/
protected theorem Balanced.fill {path : Path α} {t} :
    path.Balanced c₀ n₀ c n → t.Balanced c n → (path.fill t).Balanced c₀ n₀
  | .root, h => h
  | .redL hb H, ha | .redR ha H, hb => H.fill (.red ha hb)
  | .blackL hb H, ha | .blackR ha H, hb => H.fill (.black ha hb)

protected theorem _root_.Std.RBNode.Balanced.zoom : t.Balanced c n → path.Balanced c₀ n₀ c n →
    zoom cut t path = (t', path') → ∃ c n, t'.Balanced c n ∧ path'.Balanced c₀ n₀ c n
  | .nil, hp => fun e => by cases e; exact ⟨_, _, .nil, hp⟩
  | .red ha hb, hp => by
    unfold zoom; split
    · exact ha.zoom (.redL hb hp)
    · exact hb.zoom (.redR ha hp)
    · intro e; cases e; exact ⟨_, _, .red ha hb, hp⟩
  | .black ha hb, hp => by
    unfold zoom; split
    · exact ha.zoom (.blackL hb hp)
    · exact hb.zoom (.blackR ha hp)
    · intro e; cases e; exact ⟨_, _, .black ha hb, hp⟩

theorem ins_eq_fill {path : Path α} {t : RBNode α} :
    path.Balanced c₀ n₀ c n → t.Balanced c n → path.ins t = (path.fill t).setBlack
  | .root, h => rfl
  | .redL hb H, ha | .redR ha H, hb => by unfold ins; exact ins_eq_fill H (.red ha hb)
  | .blackL hb H, ha => by rw [ins, fill, ← ins_eq_fill H (.black ha hb), balance1_eq ha]
  | .blackR ha H, hb => by rw [ins, fill, ← ins_eq_fill H (.black ha hb), balance2_eq hb]

protected theorem Balanced.ins {path : Path α}
    (hp : path.Balanced c₀ n₀ c n) (ht : t.RedRed (c = red) n) :
    ∃ n, (path.ins t).Balanced black n := by
  induction hp generalizing t with
  | root => exact ht.setBlack
  | redL hr hp ih => match ht with
    | .balanced .nil => exact ih (.balanced (.red .nil hr))
    | .balanced (.red ha hb) => exact ih (.redred rfl (.red ha hb) hr)
    | .balanced (.black ha hb) => exact ih (.balanced (.red (.black ha hb) hr))
  | redR hl hp ih => match ht with
    | .balanced .nil => exact ih (.balanced (.red hl .nil))
    | .balanced (.red ha hb) => exact ih (.redred rfl hl (.red ha hb))
    | .balanced (.black ha hb) => exact ih (.balanced (.red hl (.black ha hb)))
  | blackL hr hp ih => exact have ⟨c, h⟩ := ht.balance1 hr; ih (.balanced h)
  | blackR hl hp ih => exact have ⟨c, h⟩ := ht.balance2 hl; ih (.balanced h)

protected theorem Balanced.insertNew {path : Path α} (H : path.Balanced c n black 0) :
    ∃ n, (path.insertNew v).Balanced black n := H.ins (.balanced (.red .nil .nil))

protected theorem Balanced.insert {path : Path α} (hp : path.Balanced c₀ n₀ c n) :
    t.Balanced c n → ∃ c n, (path.insert t v).Balanced c n
  | .nil => ⟨_, hp.insertNew⟩
  | .red ha hb => ⟨_, _, hp.fill (.red ha hb)⟩
  | .black ha hb => ⟨_, _, hp.fill (.black ha hb)⟩

theorem zoom_insert {path : Path α} {t : RBNode α} (ht : t.Balanced c n)
    (H : zoom (cmp v) t = (t', path)) :
    (path.insert t' v).setBlack = (t.insert cmp v).setBlack := by
  have ⟨_, _, ht', hp'⟩ := ht.zoom .root H
  cases ht' with simp [insert]
  | nil => simp [insertNew_eq_insert H, setBlack_idem]
  | red hl hr => rw [← ins_eq_fill hp' (.red hl hr), insert_setBlack]; exact (zoom_ins H).symm
  | black hl hr => rw [← ins_eq_fill hp' (.black hl hr), insert_setBlack]; exact (zoom_ins H).symm

protected theorem Balanced.del {path : Path α}
    (hp : path.Balanced c₀ n₀ c n) (ht : t.DelProp c' n) (hc : c = black → c' ≠ red) :
    ∃ n, (path.del t c').Balanced black n := by
  induction hp generalizing t c' with
  | root => match c', ht with
    | red, ⟨_, h⟩ | black, ⟨_, _, h⟩ => exact h.setBlack
  | @redL _ n _ _ hb hp ih => match c', n, ht with
    | red, _, _ => cases hc rfl rfl
    | black, _, ⟨_, rfl, ha⟩ => exact ih ((hb.balLeft ha).of_false (fun.)) (fun.)
  | @redR _ n _ _ ha hp ih => match c', n, ht with
    | red, _, _ => cases hc rfl rfl
    | black, _, ⟨_, rfl, hb⟩ => exact ih ((ha.balRight hb).of_false (fun.)) (fun.)
  | @blackL _ _ n _ _ _ hb hp ih => match c', n, ht with
    | red, _, ⟨_, ha⟩ => exact ih ⟨_, rfl, .redred ⟨⟩ ha hb⟩ (fun.)
    | black, _, ⟨_, rfl, ha⟩ => exact ih ⟨_, rfl, (hb.balLeft ha).imp fun _ => ⟨⟩⟩ (fun.)
  | @blackR _ _ n _ _ _ ha hp ih =>  match c', n, ht with
    | red, _, ⟨_, hb⟩ => exact ih ⟨_, rfl, .redred ⟨⟩ ha hb⟩ (fun.)
    | black, _, ⟨_, rfl, hb⟩ => exact ih ⟨_, rfl, (ha.balRight hb).imp fun _ => ⟨⟩⟩ (fun.)

/-- Asserts that `p` holds on all elements to the left of the hole. -/
def AllL (p : α → Prop) : Path α → Prop
  | .root => True
  | .left _ parent _ _ => parent.AllL p
  | .right _ a x parent => a.All p ∧ p x ∧ parent.AllL p

/-- Asserts that `p` holds on all elements to the right of the hole. -/
def AllR (p : α → Prop) : Path α → Prop
  | .root => True
  | .left _ parent x b => parent.AllR p ∧ p x ∧ b.All p
  | .right _ _ _ parent => parent.AllR p

/--
The property of a path returned by `t.zoom cut`. Each of the parents visited along the path have
the appropriate ordering relation to the cut.
-/
def Zoomed (cut : α → Ordering) : Path α → Prop
  | .root => True
  | .left _ parent x _ => cut x = .lt ∧ parent.Zoomed cut
  | .right _ _ x parent => cut x = .gt ∧ parent.Zoomed cut

theorem zoom_zoomed₁ (e : zoom cut t path = (t', path')) : t'.OnRoot (cut · = .eq) :=
  match t, e with
  | nil, rfl => trivial
  | node .., e => by
    revert e; unfold zoom; split
    · exact zoom_zoomed₁
    · exact zoom_zoomed₁
    · next H => intro e; cases e; exact H

theorem zoom_zoomed₂ (e : zoom cut t path = (t', path'))
    (hp : path.Zoomed cut) : path'.Zoomed cut :=
  match t, e with
  | nil, rfl => hp
  | node .., e => by
    revert e; unfold zoom; split
    · next h => exact fun e => zoom_zoomed₂ e ⟨h, hp⟩
    · next h => exact fun e => zoom_zoomed₂ e ⟨h, hp⟩
    · intro e; cases e; exact hp

/--
`path.RootOrdered cmp v` is true if `v` would be able to fit into the hole
without violating the ordering invariant.
-/
def RootOrdered (cmp : α → α → Ordering) : Path α → α → Prop
  | .root, _ => True
  | .left _ parent x _, v => cmpLT cmp v x ∧ parent.RootOrdered cmp v
  | .right _ _ x parent, v => cmpLT cmp x v ∧ parent.RootOrdered cmp v

theorem _root_.Std.RBNode.cmpEq.RootOrdered_congr {cmp : α → α → Ordering} (h : cmpEq cmp a b) :
    ∀ {t : Path α}, t.RootOrdered cmp a ↔ t.RootOrdered cmp b
  | .root => .rfl
  | .left .. => and_congr h.lt_congr_left h.RootOrdered_congr
  | .right .. => and_congr h.lt_congr_right h.RootOrdered_congr

theorem Zoomed.toRootOrdered {cmp} :
    ∀ {path : Path α}, path.Zoomed (cmp v) → path.RootOrdered cmp v
  | .root, h => h
  | .left .., ⟨h, hp⟩ => ⟨⟨h⟩, hp.toRootOrdered⟩
  | .right .., ⟨h, hp⟩ => ⟨⟨OrientedCmp.cmp_eq_gt.1 h⟩, hp.toRootOrdered⟩

/-- The ordering invariant for a `Path`. -/
def Ordered (cmp : α → α → Ordering) : Path α → Prop
  | .root => True
  | .left _ parent x b => parent.Ordered cmp ∧
    b.All (cmpLT cmp x ·) ∧ parent.RootOrdered cmp x ∧
    b.All (parent.RootOrdered cmp) ∧ b.Ordered cmp
  | .right _ a x parent => parent.Ordered cmp ∧
    a.All (cmpLT cmp · x) ∧ parent.RootOrdered cmp x ∧
    a.All (parent.RootOrdered cmp) ∧ a.Ordered cmp

protected theorem Ordered.fill : ∀ {path : Path α} {t},
    (path.fill t).Ordered cmp ↔ path.Ordered cmp ∧ t.Ordered cmp ∧ t.All (path.RootOrdered cmp)
  | .root, _ => ⟨fun H => ⟨⟨⟩, H, .trivial ⟨⟩⟩, (·.2.1)⟩
  | .left .., _ => by
    simp [Ordered.fill, RBNode.Ordered, Ordered, RootOrdered, All_and]
    exact ⟨
      fun ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩ => ⟨⟨hp, xb, xp, bp, hb⟩, ha, ⟨ax, ap⟩⟩,
      fun ⟨⟨hp, xb, xp, bp, hb⟩, ha, ⟨ax, ap⟩⟩ => ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩⟩
  | .right .., _ => by
    simp [Ordered.fill, RBNode.Ordered, Ordered, RootOrdered, All_and]
    exact ⟨
      fun ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩ => ⟨⟨hp, ax, xp, ap, ha⟩, hb, ⟨xb, bp⟩⟩,
      fun ⟨⟨hp, ax, xp, ap, ha⟩, hb, ⟨xb, bp⟩⟩ => ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩⟩

theorem _root_.Std.RBNode.Ordered.zoom' {t : RBNode α} {path : Path α}
    (ht : t.Ordered cmp) (hp : path.Ordered cmp) (tp : t.All (path.RootOrdered cmp))
    (pz : path.Zoomed cut) (eq : t.zoom cut path = (t', path')) :
    t'.Ordered cmp ∧ path'.Ordered cmp ∧ t'.All (path'.RootOrdered cmp) ∧ path'.Zoomed cut :=
  have ⟨hp', ht', tp'⟩ := Ordered.fill.1 <| zoom_fill eq ▸ Ordered.fill.2 ⟨hp, ht, tp⟩
  ⟨ht', hp', tp', zoom_zoomed₂ eq pz⟩

theorem _root_.Std.RBNode.Ordered.zoom {t : RBNode α}
    (ht : t.Ordered cmp) (eq : t.zoom cut = (t', path')) :
    t'.Ordered cmp ∧ path'.Ordered cmp ∧ t'.All (path'.RootOrdered cmp) ∧ path'.Zoomed cut :=
  ht.zoom' (path := .root) ⟨⟩ (.trivial ⟨⟩) ⟨⟩ eq

theorem Ordered.ins : ∀ {path : Path α} {t : RBNode α},
    t.Ordered cmp → path.Ordered cmp → t.All (path.RootOrdered cmp) → (path.ins t).Ordered cmp
  | .root, t, ht, _, _ => Ordered.setBlack.2 ht
  | .left red parent x b, a, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold ins; have ⟨ax, ap⟩ := All_and.1 H; exact hp.ins ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .right red a x parent, b, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold ins; have ⟨xb, bp⟩ := All_and.1 H; exact hp.ins ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .left black parent x b, a, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold ins; have ⟨ax, ap⟩ := All_and.1 H
    exact hp.ins (ha.balance1 ax xb hb) (balance1_All.2 ⟨xp, ap, bp⟩)
  | .right black a x parent, b, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold ins; have ⟨xb, bp⟩ := All_and.1 H
    exact hp.ins (ha.balance2 ax xb hb) (balance2_All.2 ⟨xp, ap, bp⟩)

theorem Ordered.insertNew {path : Path α} (hp : path.Ordered cmp) (vp : path.RootOrdered cmp v) :
    (path.insertNew v).Ordered cmp :=
  hp.ins ⟨⟨⟩, ⟨⟩, ⟨⟩, ⟨⟩⟩ ⟨vp, ⟨⟩, ⟨⟩⟩

theorem Ordered.insert : ∀ {path : Path α} {t : RBNode α},
    path.Ordered cmp → t.Ordered cmp → t.All (path.RootOrdered cmp) → path.RootOrdered cmp v →
    t.OnRoot (cmpEq cmp v) → (path.insert t v).Ordered cmp
  | _, nil, hp, _, _, vp, _ => hp.insertNew vp
  | _, node .., hp, ⟨ax, xb, ha, hb⟩, ⟨_, ap, bp⟩, vp, xv => Ordered.fill.2
    ⟨hp, ⟨ax.imp xv.lt_congr_right.2, xb.imp xv.lt_congr_left.2, ha, hb⟩, vp, ap, bp⟩

theorem Ordered.del : ∀ {path : Path α} {t : RBNode α} {c},
    t.Ordered cmp → path.Ordered cmp → t.All (path.RootOrdered cmp) → (path.del t c).Ordered cmp
  | .root, t, _, ht, _, _ => Ordered.setBlack.2 ht
  | .left _ parent x b, a, red, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold del; have ⟨ax, ap⟩ := All_and.1 H; exact hp.del ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .right _ a x parent, b, red, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold del; have ⟨xb, bp⟩ := All_and.1 H; exact hp.del ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .left _ parent x b, a, black, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold del; have ⟨ax, ap⟩ := All_and.1 H
    exact hp.del (ha.balLeft ax xb hb) (ap.balLeft xp bp)
  | .right _ a x parent, b, black, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold del; have ⟨xb, bp⟩ := All_and.1 H
    exact hp.del (ha.balRight ax xb hb) (ap.balRight xp bp)

theorem Ordered.erase : ∀ {path : Path α} {t : RBNode α},
    path.Ordered cmp → t.Ordered cmp → t.All (path.RootOrdered cmp) → (path.erase t).Ordered cmp
  | _, nil, hp, ht, tp => Ordered.fill.2 ⟨hp, ht, tp⟩
  | _, node .., hp, ⟨ax, xb, ha, hb⟩, ⟨_, ap, bp⟩ => hp.del (ha.append ax xb hb) (ap.append bp)

end Path

/-! ## alter -/

/-- The `alter` function preserves the ordering invariants. -/
protected theorem Ordered.alter {t : RBNode α}
    (H : ∀ {x t' p}, t.zoom cut = (t', p) → f t'.root? = some x →
      p.RootOrdered cmp x ∧ t'.OnRoot (cmpEq cmp x))
    (h : t.Ordered cmp) : (alter cut f t).Ordered cmp := by
  simp [alter]; split
  · next path eq =>
    have ⟨_, hp, _, _⟩ := h.zoom eq; split
    · exact h
    · next hf => exact hp.insertNew (H eq hf).1
  · next path eq =>
    have ⟨⟨ax, xb, ha, hb⟩, hp, ⟨_, ap, bp⟩, _⟩ := h.zoom eq; split
    · exact hp.del (ha.append ax xb hb) (ap.append bp)
    · next hf =>
      have ⟨yp, xy⟩ := H eq hf
      apply Path.Ordered.fill.2
      exact ⟨hp, ⟨ax.imp xy.lt_congr_right.2, xb.imp xy.lt_congr_left.2, ha, hb⟩, yp, ap, bp⟩

/-- The `alter` function preserves the balance invariants. -/
protected theorem Balanced.alter {t : RBNode α}
    (h : t.Balanced c n) : ∃ c n, (t.alter cut f).Balanced c n := by
  simp [alter]; split
  · next path eq =>
    split
    · exact ⟨_, _, h⟩
    · have ⟨_, _, .nil, h⟩ := h.zoom .root eq
      exact ⟨_, h.insertNew⟩
  · next path eq =>
    have ⟨_, _, h, hp⟩ := h.zoom .root eq
    split
    · match h with
      | .red ha hb => exact ⟨_, hp.del ((ha.append hb).of_false (· rfl rfl)) (fun.)⟩
      | .black ha hb => exact ⟨_, hp.del ⟨_, rfl, (ha.append hb).imp fun _ => ⟨⟩⟩ (fun.)⟩
    · match h with
      | .red ha hb => exact ⟨_, _, hp.fill (.red ha hb)⟩
      | .black ha hb => exact ⟨_, _, hp.fill (.black ha hb)⟩

theorem modify_eq_alter (t : RBNode α) : t.modify cut f = t.alter cut (.map f) := by
  simp [modify, alter]; split <;> simp [Option.map]

/-- The `modify` function preserves the ordering invariants. -/
protected theorem Ordered.modify {t : RBNode α}
    (H : (t.zoom cut).1.OnRoot fun x => cmpEq cmp (f x) x)
    (h : t.Ordered cmp) : (modify cut f t).Ordered cmp :=
  modify_eq_alter _ ▸ h.alter @fun
    | _, .node .., _, eq, rfl => by
      rw [eq] at H; exact ⟨H.RootOrdered_congr.2 (h.zoom eq).2.2.1.1, H⟩

/-- The `modify` function preserves the balance invariants. -/
protected theorem Balanced.modify {t : RBNode α}
    (h : t.Balanced c n) : ∃ c n, (t.modify cut f).Balanced c n := modify_eq_alter _ ▸ h.alter

theorem WF.alter {t : RBNode α}
    (H : ∀ {x t' p}, t.zoom cut = (t', p) → f t'.root? = some x →
      p.RootOrdered cmp x ∧ t'.OnRoot (cmpEq cmp x))
    (h : WF cmp t) : WF cmp (alter cut f t) :=
  let ⟨h₁, _, _, h₂⟩ := h.out; WF_iff.2 ⟨h₁.alter H, h₂.alter⟩

theorem WF.modify {t : RBNode α}
    (H : (t.zoom cut).1.OnRoot fun x => cmpEq cmp (f x) x)
    (h : WF cmp t) : WF cmp (t.modify cut f) :=
  let ⟨h₁, _, _, h₂⟩ := h.out; WF_iff.2 ⟨h₁.modify H, h₂.modify⟩

theorem find?_eq_zoom : ∀ {t : RBNode α} (p := .root), t.find? cut = (t.zoom cut p).1.root?
  | .nil, _ => rfl
  | .node .., _ => by unfold find? zoom; split <;> [apply find?_eq_zoom, apply find?_eq_zoom, rfl]

end RBNode

namespace RBSet
open RBNode

/--
A sufficient condition for `ModifyWF` is that the new element compares equal to the original.
-/
theorem ModifyWF.of_eq {t : RBSet α cmp}
    (H : ∀ {x}, RBNode.find? cut t.val = some x → cmpEq cmp (f x) x) : ModifyWF t cut f := by
  refine ⟨.modify ?_ t.2⟩
  revert H; rw [find?_eq_zoom]
  (cases (t.1.zoom cut).1 <;> intro H) <;> [trivial, exact H rfl]

end RBSet

namespace RBMap

/--
`O(log n)`. In-place replace the corresponding to key `k`.
This takes the element out of the tree while `f` runs,
so it uses the element linearly if `t` is unshared.
-/
def modify (t : RBMap α β cmp) (k : α) (f : β → β) : RBMap α β cmp :=
  @RBSet.modifyP _ _ t (cmp k ·.1) (fun (a, b) => (a, f b))
    (.of_eq fun _ => ⟨OrientedCmp.cmp_refl (cmp := byKey Prod.fst cmp)⟩)

/-- Auxiliary definition for `alter`. -/
def alter.adapt (k : α) (f : Option β → Option β) : Option (α × β) → Option (α × β)
  | none =>
    match f none with
    | none => none
    | some v => some (k, v)
  | some (k', v') =>
    match f (some v') with
    | none => none
    | some v => some (k', v)

/--
`O(log n)`. `alterP cut f t` simultaneously handles inserting, erasing and replacing an element
using a function `f : Option α → Option α`. It is passed the result of `t.findP? cut`
and can either return `none` to remove the element or `some a` to replace/insert
the element with `a` (which must have the same ordering properties as the original element).

The element is used linearly if `t` is unshared.

The `AlterWF` assumption is required because `f` may change
the ordering properties of the element, which would break the invariants.
-/
@[specialize] def alter
    (t : RBMap α β cmp) (k : α) (f : Option β → Option β) : RBMap α β cmp := by
  refine @RBSet.alterP _ _ t (cmp k ·.1) (alter.adapt k f) ⟨.alter (@fun _ t' p eq => ?_) t.2⟩
  cases t' <;> simp [alter.adapt, RBNode.root?] <;> split <;> intro h <;> cases h
  · exact ⟨(t.2.out.1.zoom eq).2.2.2.toRootOrdered, ⟨⟩⟩
  · refine ⟨(?a).RootOrdered_congr.2 (t.2.out.1.zoom eq).2.2.1.1, ?a⟩
    exact ⟨OrientedCmp.cmp_refl (cmp := byKey Prod.fst cmp)⟩

end RBMap


import o_minimal.sheaf.constants

namespace o_minimal

variables {R : Type*} {S : struc R}
variables {X : Type*} [definable_sheaf S X]
variables {X' : Type*} [definable_sheaf S X']
variables {X'' : Type*} [definable_sheaf S X'']
variables {L K : Def S}

lemma definable_fun {f : X → X'} :
  definable S f ↔
  ∀ (K : Def S) (φ : K → X), definable_sheaf.definable φ → definable_sheaf.definable (f ∘ φ) :=
begin
  -- TODO: Merge with following proof?
  split; intro H,
  { cases H,
    intros K φ hφ,
    exact H K K (λ k, (k, φ k)) ⟨def_fun.id, hφ⟩ },
  { refine ⟨λ M L φ hφ, _⟩,
    exact H _ _ hφ.2 }
end

lemma definable_yoneda {f : K → X} :
  definable S f ↔ definable_sheaf.definable f :=
begin
  split; intro H,
  { cases H,
    -- This proof is a bit mysterious, related to the perhaps
    -- odd definition of `definable S`.
    -- Really we could use any `Def S` as the first argument
    -- to `H`; `K` is just one we have handy here.
    exact H K K (λ k, (k, k)) ⟨def_fun.id, def_fun.id⟩ },
  { refine ⟨λ M L φ hφ, _⟩,
    exact definable_sheaf.definable_precomp ⟨_, hφ.2⟩ f H }
end

lemma Def.definable_iff_def_fun {f : L → K} : definable S f ↔ def_fun S f :=
definable_yoneda

lemma Def.definable_iff_def_set {s : set K} : definable S s ↔ def_set S s :=
definable_yoneda

instance self.definable_sheaf : definable_sheaf S R :=
definable_sheaf.rep

section

variables (S)

class definable_rep (W : Type*) [has_coordinates R W]
  extends is_definable S W, definable_sheaf S W :=
(eq : ∀ (K : Def S) (f : K → W), definable_sheaf.definable f ↔ def_fun S f)

instance self.definable_rep : definable_rep S R := { eq := λ K f, iff.rfl }

instance Def.definable_rep {K : Def S} : definable_rep S K :=
{ eq := λ _ f, iff.rfl }

variables (W : Type*) [has_coordinates R W] [is_definable S W]

def as_Def : Def S :=
{ ambdim := _,
  to_set := coordinate_image R W,
  is_definable := def_fun.coords.range }

-- TODO: Should we adjust the definition of `has_coordinates`
-- to make this computable?
noncomputable def equiv_Def : W ≃ as_Def S W :=
equiv.of_bijective (set.range_factorization (@coords R W _))
⟨λ w₁ w₂ h, @injective_coords R W _ w₁ w₂ (subtype.ext_iff.mp h),
 set.surjective_onto_range⟩

variables {S W}

lemma def_fun_equiv_Def : def_fun S (equiv_Def S W) :=
def_fun_subtype_mk def_fun.coords _

lemma def_fun_equiv_Def_symm : def_fun S (equiv_Def S W).symm :=
begin
  refine def_fun.cancel def_fun_equiv_Def (equiv.injective _) _,
  simpa using def_fun.id
end

end

variables {Y : Type*} [has_coordinates R Y] [definable_rep S Y]
variables {Y' : Type*} [has_coordinates R Y'] [definable_rep S Y']
variables {Z : Type*} [has_coordinates R Z] [definable_rep S Z]

lemma definable_iff_from_Def {f : Y → X} :
  definable S f ↔ definable_sheaf.definable (f ∘ (equiv_Def S Y).symm) :=
begin
  rw definable_fun,
  split; intro H,
  { apply H,
    rw definable_rep.eq,
    apply def_fun_equiv_Def_symm },
  { intros K φ hφ,
    rw definable_rep.eq at hφ,
    have : def_fun S (equiv_Def S Y ∘ φ) := def_fun_equiv_Def.comp hφ,
    convert definable_sheaf.definable_precomp ⟨equiv_Def S Y ∘ φ, this⟩ _ H,
    change φ = ((equiv_Def S Y).symm ∘ equiv_Def S Y) ∘ φ,
    simp }
end

lemma definable_iff_def_fun {f : Y → Z} :
  definable S f ↔ def_fun S f :=
begin
  rw definable_iff_from_Def,
  rw definable_rep.eq,
  split; intro H,
  { convert H.comp def_fun_equiv_Def,
    change f = f ∘ _,
    simp },
  { exact H.comp def_fun_equiv_Def_symm }
end

lemma definable_iff_def_set {s : set Y} :
  definable S s ↔ def_set S s :=
begin
  rw definable_iff_from_Def,
  split; intro H,
  { convert def_fun_equiv_Def.preimage H,
    change s = s ∘ _,
    simp },
  { exact def_fun_equiv_Def_symm.preimage H }
end

-- Yoneda embedding commutes with products
instance prod.definable_rep : definable_rep S (Y × Y') :=
begin
  refine { eq := λ K f, _ },
  change _ ∧ _ ↔ _,
  rw [definable_rep.eq, definable_rep.eq],
  split; intro H,
  { convert def_fun.prod' H.1 H.2,
    ext; refl },
  { exact ⟨def_fun.fst.comp H, def_fun.snd.comp H⟩ }
end

lemma definable_iff_uncurry {f : X → X' → X''} :
  definable S f ↔ definable S (function.uncurry f) :=
⟨λ H, definable.uncurry.app H, λ H, definable.curry.app H⟩

lemma definable_iff_def_fun₂ {f : Y → Y' → Z} :
  definable S f ↔ def_fun S (function.uncurry f) :=
definable_iff_uncurry.trans definable_iff_def_fun

lemma definable_iff_def_rel₂ {s : Y → Y' → Prop} :
  definable S s ↔ def_set S {p : Y × Y' | s p.1 p.2} :=
definable_iff_uncurry.trans definable_iff_def_set

-- TODO: Does this hold more generally than for representable codomains?
lemma definable_of_graph {f : X → Y} (df : definable S {p : X × Y | f p.1 = p.2}) :
  definable S f :=
begin
  rw definable_fun,
  intros K φ hφ,
  rw ←definable_yoneda at hφ,
  rw definable_rep.eq,
  change def_set S ({p : X × Y | f p.1 = p.2} ∘ (λ (q : K × Y), (φ q.1, q.2))),
  rw ←definable_iff_def_set,
  refine df.comp _,
  -- TODO: use more convenient lemmas
  begin [defin]
    intro q,
    app, app, exact definable.prod_mk.definable _,
    app, exact hφ.definable _,
    app, exact definable.fst.definable _, var,
    app, exact definable.snd.definable _, var
  end
end

def subtype.definable_rep {s : set Y} (ds : definable S s) : definable_rep S s :=
{ eq := λ K f, (definable_rep.eq K (subtype.val ∘ f)).trans def_fun_subtype_iff.symm,
  .. is_definable.subtype (definable_iff_def_set.mp ds) }

end o_minimal


def n: ℕ := 1

lemma p: 0 = 0 := eq.refl 0
lemma s: "Hello Lean!" = "Hello Lean!" := eq.refl "Hello Lean!"

lemma s1: tt = tt := eq.refl tt

/-def p' : 0 = 0 := eq.refl 1-/

theorem s' : 0 = 0 := eq.refl 0

lemma oeqo : 1 = 1 := eq.refl 1

lemma teqt: 2 = 1 + 1 := eq.refl (1+1)

lemma h : "Hello" = "He" ++ "llo" := rfl
lemma pp : 3*3 + 4*4 = 5*5 := rfl
lemma tthof : 2 + 3 = 1 + 4 := rfl
lemma hpleqhl : "Hello " ++ "Lean!" = "Hello Lean!" := rfl

#check "Hello" = "Hello"


import algebra.homology.additive
import category_theory.abelian.basic
import category_theory.limits.constructions.epi_mono

open category_theory category_theory.limits

namespace homological_complex

universes w' w v v' u u'

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

--move this
lemma congr_f [has_zero_morphisms V] {X Y : homological_complex V c} {f g : X ⟶ Y}
  (h : f = g) (x : ι) : f.f x = g.f x := congr_arg _ h

section limits

noncomputable theory

variables [has_zero_morphisms V] (F : J ⥤ homological_complex V c)

include F

@[simps]
def lift_of_is_limit_eval (t : cone F) (h : ∀ i, is_limit $ (eval V c i).map_cone t) (s : cone F) :
  s.X ⟶ t.X :=
begin
  refine ⟨λ i, is_limit.lift (h i) ⟨_, _⟩, _⟩,
  refine ⟨λ x, (s.π.app x).f i, _⟩,
  { intros x y f, dsimp, rw [category.id_comp, ← comp_f], congr, exact (cone.w s f).symm },
  { intros i j r,
    apply (h j).hom_ext,
    intro x,
    dsimp,
    rw [category.assoc, category.assoc],
    erw [← (t.π.app x).comm, (h j).fac _ x, (h i).fac_assoc _ x, (s.π.app x).comm],
    refl }
end
.
/-- `eval` jointly reflects (actually creates) limits -/
def is_limit_of_is_limit_eval (t : cone F) (h : ∀ i, is_limit $ (eval V c i).map_cone t) :
  is_limit t :=
{ lift := lift_of_is_limit_eval F t h,
  fac' := by { intros s j, ext, dsimp, exact (h x).fac _ j },
  uniq' := by { intros s m w, ext, apply (h x).hom_ext,
    intro j, dsimp, erw (h x).fac _ j, exact congr_f (w j) x } }

variables [∀ i : ι, has_limit (F ⋙ eval V c i)]

@[simps]
def limit_complex : homological_complex V c :=
begin
  refine ⟨λ i, limit (F ⋙ eval V c i), λ i j, limit.lift _ ⟨_, _⟩, _, _⟩,
  refine ⟨λ k, limit.π (F ⋙ eval V c i) k ≫ (F.obj k).d i j, _⟩,
  { intros x y f,
    dsimp,
    rw [category.id_comp, category.assoc, ← hom.comm, ← category.assoc],
    congr' 1,
    exact (limit.w _ _).symm },
  { intros i j r,
    ext k,
    rw [limit.lift_π, zero_comp],
    dsimp only,
    rw [(F.obj k).shape _ _ r, comp_zero] },
  { intros i j k r r', ext, simp }
end
.
@[simps]
def limit_complex_cone : cone F :=
{ X := limit_complex F,
  π := { app := λ x, { f := λ i, limit.π (F ⋙ eval V c i) x },
    naturality' := λ X Y f, by { ext, dsimp, rw category.id_comp, exact (limit.w _ _).symm } } }
.
def limit_complex_cone_is_limit : is_limit (limit_complex_cone F) :=
is_limit_of_is_limit_eval _ _
begin
  intro i,
  apply (limit.is_limit _).of_iso_limit,
  exact cones.ext (iso.refl _) (λ _, (category.id_comp _).symm),
end

def eval_map_limit_complex_cone (i : ι) :
  (eval V c i).map_cone (limit_complex_cone F) ≅ (get_limit_cone (F ⋙ eval V c i)).1 :=
cones.ext (iso.refl _) (λ j, by { dsimp, simpa })

instance (i : ι) : preserves_limit F (eval V c i) :=
preserves_limit_of_preserves_limit_cone (limit_complex_cone_is_limit F)
  ((limit.is_limit _).of_iso_limit (eval_map_limit_complex_cone F i).symm)

instance : has_limit F :=
⟨⟨⟨_, limit_complex_cone_is_limit F⟩⟩⟩

omit F

instance [has_limits_of_shape J V] : has_limits_of_shape J (homological_complex V c) := {}
instance [has_limits_of_size.{w' w} V] : has_limits_of_size.{w' w} (homological_complex V c) := ⟨⟩
instance [has_limits_of_shape J V] (i : ι) : preserves_limits_of_shape J (eval V c i) := {}
instance [has_limits_of_size.{w' w} V] (i : ι) : preserves_limits_of_size.{w' w} (eval V c i) := {}

end limits

section colimits

noncomputable theory

variables [has_zero_morphisms V] (F : J ⥤ homological_complex V c)

include F

@[simps]
def desc_of_is_colimit_eval (t : cocone F) (h : ∀ i, is_colimit $ (eval V c i).map_cocone t)
  (s : cocone F) :
  t.X ⟶ s.X :=
begin
  refine ⟨λ i, is_colimit.desc (h i) ⟨_, _⟩, _⟩,
  refine ⟨λ x, (s.ι.app x).f i, _⟩,
  { intros x y f, dsimp, rw [category.comp_id, ← comp_f], congr, exact cocone.w s f },
  { intros i j r,
    apply (h i).hom_ext,
    intro x,
    dsimp,
    erw [(t.ι.app x).comm_assoc, (h j).fac _ x, (h i).fac_assoc _ x, (s.ι.app x).comm] }
end
.
/-- `eval` jointly reflects (actually creates) colimits -/
def is_colimit_of_is_colimit_eval (t : cocone F) (h : ∀ i, is_colimit $ (eval V c i).map_cocone t) :
  is_colimit t :=
{ desc := desc_of_is_colimit_eval F t h,
  fac' := by { intros s j, ext, dsimp, exact (h x).fac _ j },
  uniq' := by { intros s m w, ext, apply (h x).hom_ext,
    intro j, dsimp, erw (h x).fac _ j, exact congr_f (w j) x } }

variable [∀ i : ι, has_colimit (F ⋙ eval V c i)]

@[simps]
def colimit_complex : homological_complex V c :=
begin
  refine ⟨λ i, colimit (F ⋙ eval V c i), λ i j, colimit.desc _ ⟨_, _⟩, _, _⟩,
  refine ⟨λ x, (F.obj x).d i j ≫ colimit.ι (F ⋙ eval V c j) x, _⟩,
  { intros x y f,
    dsimp,
    rw [category.comp_id, hom.comm_assoc],
    congr' 1,
    exact colimit.w (F ⋙ eval V c j) _ },
  { intros i j r,
    ext x,
    rw [colimit.ι_desc, comp_zero],
    dsimp only,
    rw [(F.obj x).shape _ _ r, zero_comp] },
  { intros i j k r r', ext, simp }
end
.
@[simps]
def colimit_complex_cocone : cocone F :=
{ X := colimit_complex F,
  ι := { app := λ x, { f := λ i, colimit.ι (F ⋙ eval V c i) x },
    naturality' := λ X Y f,
      by { ext, dsimp, rw category.comp_id, exact colimit.w (F ⋙ eval V c x) _ } } }
.

def colimit_complex_cocone_is_colimit : is_colimit (colimit_complex_cocone F) :=
is_colimit_of_is_colimit_eval _ _
begin
  intro i,
  apply (colimit.is_colimit _).of_iso_colimit,
  exact cocones.ext (iso.refl _) (λ _, category.comp_id _),
end
.

def eval_map_colimit_complex_cocone (i : ι) :
  (eval V c i).map_cocone (colimit_complex_cocone F) ≅ (get_colimit_cocone (F ⋙ eval V c i)).1 :=
cocones.ext (iso.refl _) (λ j, by { dsimp, simpa })

instance (i : ι) : preserves_colimit F (eval V c i) :=
preserves_colimit_of_preserves_colimit_cocone (colimit_complex_cocone_is_colimit F)
  ((colimit.is_colimit _).of_iso_colimit (eval_map_colimit_complex_cocone F i).symm)

instance : has_colimit F :=
⟨⟨⟨_, colimit_complex_cocone_is_colimit F⟩⟩⟩

omit F

instance [has_colimits_of_shape J V] : has_colimits_of_shape J (homological_complex V c) := {}
instance [has_colimits_of_size.{w' w} V] : has_colimits_of_size.{w' w} (homological_complex V c) :=
{}

instance [has_colimits_of_shape J V] (i : ι) : preserves_colimits_of_shape J (eval V c i) := {}
instance [has_colimits_of_size.{w' w} V] (i : ι) :
  preserves_colimits_of_size.{w' w} (eval V c i) := {}

end colimits

section biproduct

variables [has_zero_morphisms V] [has_binary_biproducts V] {X Y Z : homological_complex V c}

@[simps]
def biproduct (X Y : homological_complex V c) : homological_complex V c :=
{ X := λ i, X.X i ⊞ Y.X i,
  d := λ i j, biprod.map (X.d i j) (Y.d i j),
  shape' := λ i j r, by ext; simp [X.shape _ _ r, Y.shape _ _ r] }
.
@[simps] def biproduct.inl : X ⟶ biproduct X Y := { f := λ i, biprod.inl }
@[simps] def biproduct.inr : Y ⟶ biproduct X Y := { f := λ i, biprod.inr }
@[simps] def biproduct.fst : biproduct X Y ⟶ X := { f := λ i, biprod.fst }
@[simps] def biproduct.snd : biproduct X Y ⟶ Y := { f := λ i, biprod.snd }
@[simps] def biproduct.lift (f : X ⟶ Y) (g : X ⟶ Z) : X ⟶ biproduct Y Z :=
{ f := λ i, biprod.lift (f.f i) (g.f i) }
@[simps] def biproduct.desc (f : X ⟶ Z) (g : Y ⟶ Z) : biproduct X Y ⟶ Z :=
{ f := λ i, biprod.desc (f.f i) (g.f i) }
.
variables (X Y)
@[simps]
def biproduct_bicone : binary_bicone X Y :=
{ X := biproduct X Y,
  fst := biproduct.fst,
  snd := biproduct.snd,
  inl := biproduct.inl,
  inr := biproduct.inr }
.
local attribute [tidy] tactic.case_bash

def biproduct_bicone_is_prod : is_limit (biproduct_bicone X Y).to_cone :=
{ lift := λ (Z : binary_fan _ _), biproduct.lift Z.fst Z.snd,
  uniq' := by { intros, delta binary_fan.fst binary_fan.snd, ext; simp [← w] } }
.
def biproduct_bicone_is_coprod : is_colimit (biproduct_bicone X Y).to_cocone :=
{ desc := λ (Z : binary_cofan _ _), biproduct.desc Z.inl Z.inr,
  uniq' := by { intros, delta binary_cofan.inl binary_cofan.inr, ext; simp [← w] } }
.
def biproduct_is_biprod : binary_biproduct_data X Y :=
{ bicone := biproduct_bicone X Y,
  is_bilimit := ⟨biproduct_bicone_is_prod X Y, biproduct_bicone_is_coprod X Y⟩ }

instance : has_binary_biproducts (homological_complex V c) :=
⟨λ X Y, ⟨⟨biproduct_is_biprod X Y⟩⟩⟩

end biproduct

instance [has_zero_morphisms V] [has_finite_products V] :
  has_finite_products (homological_complex V c) := ⟨λ J _, by exactI infer_instance⟩

-- instance [has_zero_morphisms V] [has_kernels V] : has_kernels (homological_complex V c) :=
-- begin
--   constructor,
--   intros X Y f,
--   apply_with homological_complex.category_theory.limits.has_limit { instances := ff },
--   intro i,
--   let : walking_parallel_pair_op_equiv.{v v}.functor ⋙ walking_parallel_pair_op_equiv.inverse ⋙
--     parallel_pair f 0 ⋙ eval V c i ≅ parallel_pair (f.f i) 0 :=
--     nat_iso.of_components (λ i, eq_to_iso $ by cases i; refl)
--       (by { rintros _ _ (_|_|_); dsimp; simp }),
--   have := has_limit_of_iso this.symm,
--   exact @@has_limit_of_equivalence_comp _ _ _
--     (walking_parallel_pair_op_equiv.{v v}.trans walking_parallel_pair_op_equiv.symm) this
-- end

-- instance [has_zero_morphisms V] [has_cokernels V] :
--   has_cokernels (homological_complex V c) :=
-- begin
--   constructor,
--   intros X Y f,
--   apply_with homological_complex.category_theory.limits.has_colimit { instances := ff },
--   intro i,
--   let : walking_parallel_pair_op_equiv.{v v}.functor ⋙ walking_parallel_pair_op_equiv.inverse ⋙
--     parallel_pair f 0 ⋙ eval V c i ≅ parallel_pair (f.f i) 0 :=
--     nat_iso.of_components (λ i, eq_to_iso $ by cases i; refl)
--       (by { rintros _ _ (_|_|_); dsimp; simp }),
--   have := has_colimit_of_iso this,
--   exact @@has_colimit_of_equivalence_comp _ _ _
--     (walking_parallel_pair_op_equiv.{v v}.trans walking_parallel_pair_op_equiv.symm) this
-- end

section kernel

variables [has_zero_morphisms V] {X Y : homological_complex V c}
variables (f : X ⟶ Y) [∀ i, has_kernel (f.f i)]

@[simps]
def kernel_complex : homological_complex V c :=
{ X := λ i, kernel (f.f i),
  d := λ i j, kernel.map _ _ _ _ (f.comm i j),
  shape' := by { introv r, ext, simp [X.shape _ _ r] } }
.
@[simps]
def kernel_complex_ι : kernel_complex f ⟶ X :=
{ f := λ i, kernel.ι (f.f i) }
.
@[simps]
def kernel_complex_fork : kernel_fork f :=
kernel_fork.of_ι (kernel_complex_ι f) (by { ext, simp })
.
@[simps]
def kernel_complex_lift (s : kernel_fork f) : s.X ⟶ kernel_complex f :=
{ f := λ i, kernel.lift _ (s.ι.f i)
    (by { rw [← comp_f, kernel_fork.condition], refl }) }

def kernel_complex_is_kernel : is_limit (kernel_complex_fork f) :=
begin
  apply is_limit_aux (kernel_complex_fork f) (kernel_complex_lift f),
  { intro s, ext, delta fork.ι, dsimp, simp only [kernel.lift_ι] },
  { intros s m h, ext, apply_fun (λ f, hom.f f x) at h,
    delta fork.ι at h, dsimp at h ⊢, simp [h, kernel.lift_ι] }
end
.
instance : has_kernel f := ⟨⟨⟨_, kernel_complex_is_kernel f⟩⟩⟩
instance [has_kernels V] : has_kernels (homological_complex V c) := {}
.
end kernel

section cokernel

variables [has_zero_morphisms V] {X Y : homological_complex V c}
variables (f : X ⟶ Y) [∀ i, has_cokernel (f.f i)]

@[simps]
def cokernel_complex : homological_complex V c :=
{ X := λ i, cokernel (f.f i),
  d := λ i j, cokernel.map _ _ _ _ (f.comm i j),
  shape' := by { introv r, ext, simp [Y.shape _ _ r] } }
.
@[simps]
def cokernel_complex_π : Y ⟶ cokernel_complex f :=
{ f := λ i, cokernel.π (f.f i) }
.
@[simps]
def cokernel_complex_cofork : cokernel_cofork f :=
cokernel_cofork.of_π (cokernel_complex_π f) (by { ext, simp })
.
@[simps]
def cokernel_complex_desc (s : cokernel_cofork f) : cokernel_complex f ⟶ s.X :=
{ f := λ i, cokernel.desc _ (s.π.f i)
    (by { rw [← comp_f, cokernel_cofork.condition], refl }) }

def cokernel_complex_is_cokernel : is_colimit (cokernel_complex_cofork f) :=
begin
  apply is_colimit_aux (cokernel_complex_cofork f) (cokernel_complex_desc f),
  { intro s, ext, delta cofork.π, dsimp, simp only [cokernel.π_desc] },
  { intros s m h, ext, apply_fun (λ f, hom.f f x) at h,
    delta cofork.π at h, dsimp at h ⊢, simp only [h, cokernel.π_desc] }
end
.
instance : has_cokernel f := ⟨⟨⟨_, cokernel_complex_is_cokernel f⟩⟩⟩
instance [has_cokernels V] : has_cokernels (homological_complex V c) := {}
.
end cokernel

section normal_mono

variables [abelian V] {X Y Z : homological_complex V c}
variables (f : X ⟶ Y)

def is_kernel_of_eval (g : Y ⟶ Z) (w : f ≫ g = 0)
  (h : ∀ i, is_limit (kernel_fork.of_ι (f.f i) (congr_f w i))) :
  is_limit (kernel_fork.of_ι f w) :=
begin
  refine is_limit.of_iso_limit (kernel_complex_is_kernel g) _,
  fapply cones.ext,
  fapply hom.iso_of_components,
  intro i, exact limit.iso_limit_cone ⟨_, h i⟩,
  { intros i j r, dsimp, rw [← iso.comp_inv_eq, category.assoc, ← iso.eq_inv_comp], ext, simp },
  { rintro (_|_),
    { ext, dsimp, rw ← iso.inv_comp_eq, simp },
    { ext, dsimp, simp [(show f.f x ≫ g.f x = _, from congr_f w x)] } }
end

def is_cokernel_of_eval (g : Y ⟶ Z) (w : f ≫ g = 0)
  (h : ∀ i, is_colimit (cokernel_cofork.of_π (g.f i) (congr_f w i))) :
  is_colimit (cokernel_cofork.of_π g w) :=
begin
  refine is_colimit.of_iso_colimit (cokernel_complex_is_cokernel f) _,
  fapply cocones.ext,
  fapply hom.iso_of_components,
  intro i, exact colimit.iso_colimit_cocone ⟨_, h i⟩,
  { intros i j r, ext, dsimp, simp },
  { rintro (_|_),
    { ext, dsimp, simpa using (congr_arg (λ f, hom.f f x) w).symm },
    { ext, dsimp, simp } }
end
.

instance [mono f] (i : ι) : mono (f.f i) :=
begin
  change mono ((eval V c i).map f),
  apply_instance
end

lemma mono_of_eval [∀ i, mono (f.f i)] : mono f :=
begin
  constructor,
  intros Z g h r,
  ext i,
  rw ← cancel_mono (f.f i),
  exact congr_f r i
end

lemma mono_iff_eval : mono f ↔ ∀ i, mono (f.f i) :=
⟨λ _ i, by exactI infer_instance, λ _, by exactI mono_of_eval f⟩

instance [epi f] (i : ι) : epi (f.f i) :=
begin
  change epi ((eval V c i).map f),
  apply_instance
end

lemma epi_of_eval [∀ i, epi (f.f i)] : epi f :=
begin
  constructor,
  intros Z g h r,
  ext i,
  rw ← cancel_epi (f.f i),
  exact congr_f r i
end

lemma epi_iff_eval : epi f ↔ ∀ i, epi (f.f i) :=
⟨λ _ i, by exactI infer_instance, λ _, by exactI epi_of_eval f⟩

def normal_mono [mono f] : normal_mono f :=
{ Z := cokernel_complex f,
  g := cokernel_complex_π f,
  w := by { ext, simp },
  is_limit :=
  begin
    apply is_kernel_of_eval,
    intro i,
    exact abelian.mono_is_kernel_of_cokernel _ (colimit.is_colimit _)
  end }

def normal_epi [epi f] : normal_epi f :=
{ W := kernel_complex f,
  g := kernel_complex_ι f,
  w := by { ext, simp },
  is_colimit :=
  begin
    apply is_cokernel_of_eval,
    intro i,
    exact abelian.epi_is_cokernel_of_kernel _ (limit.is_limit _)
  end }
.

end normal_mono

instance [abelian V] : abelian (homological_complex V c) :=
{ normal_mono_of_mono := λ _ _, normal_mono,
  normal_epi_of_epi := λ _ _, normal_epi }

end homological_complex


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

Transferring `traversable` instances using isomorphisms.
-/
import data.equiv.basic
import control.traversable.lemmas

universes u

namespace equiv

section functor
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [functor t]

open functor

/-- Given a functor `t`, a function `t' : Type u → Type u`, and
equivalences `t α ≃ t' α` for all `α`, then every function `α → β` can
be mapped to a function `t' α → t' β` functorially (see
`equiv.functor`). -/
protected def map {α β : Type u} (f : α → β) (x : t' α) : t' β :=
eqv β $ map f ((eqv α).symm x)

/-- The function `equiv.map` transfers the functoriality of `t` to
`t'` using the equivalences `eqv`.  -/
protected def functor : functor t' :=
{ map := @equiv.map _ }

variables [is_lawful_functor t]

protected lemma id_map {α : Type u} (x : t' α) : equiv.map id x = x :=
by simp [equiv.map, id_map]

protected lemma comp_map {α β γ : Type u} (g : α → β) (h : β → γ) (x : t' α) :
  equiv.map (h ∘ g) x = equiv.map h (equiv.map g x) :=
by simp [equiv.map]; apply comp_map

protected lemma is_lawful_functor : @is_lawful_functor _ equiv.functor :=
{ id_map := @equiv.id_map _ _,
  comp_map := @equiv.comp_map _ _ }

protected lemma is_lawful_functor' [F : _root_.functor t']
  (h₀ : ∀ {α β} (f : α → β), _root_.functor.map f = equiv.map f)
  (h₁ : ∀ {α β} (f : β), _root_.functor.map_const f = (equiv.map ∘ function.const α) f) :
  _root_.is_lawful_functor t' :=
begin
  have : F = equiv.functor,
  { casesI F, dsimp [equiv.functor],
    congr; ext; [rw ← h₀, rw ← h₁] },
  substI this,
  exact equiv.is_lawful_functor
end

end functor

section traversable
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t]
variables {m : Type u → Type u} [applicative m]
variables {α β : Type u}

/-- Like `equiv.map`, a function `t' : Type u → Type u` can be given
the structure of a traversable functor using a traversable functor
`t'` and equivalences `t α ≃ t' α` for all α.  See `equiv.traversable`. -/
protected def traverse (f : α → m β) (x : t' α) : m (t' β) :=
eqv β <$> traverse f ((eqv α).symm x)

/-- The function `equiv.tranverse` transfers a traversable functor
instance across the equivalences `eqv`. -/
protected def traversable : traversable t' :=
{ to_functor := equiv.functor eqv,
  traverse := @equiv.traverse _ }

end traversable

section equiv
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t] [is_lawful_traversable t]
variables {F G : Type u → Type u} [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]
variables (η : applicative_transformation F G)
variables {α β γ : Type u}

open is_lawful_traversable functor

protected lemma id_traverse (x : t' α) :
  equiv.traverse eqv id.mk x = x :=
by simp! [equiv.traverse,id_bind,id_traverse,functor.map] with functor_norm

protected lemma traverse_eq_map_id (f : α → β) (x : t' α) :
  equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) :=
by simp [equiv.traverse, traverse_eq_map_id] with functor_norm; refl

protected lemma comp_traverse (f : β → F γ) (g : α → G β) (x : t' α) :
  equiv.traverse eqv (comp.mk ∘ functor.map f ∘ g) x =
  comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) :=
by simp [equiv.traverse,comp_traverse] with functor_norm; congr; ext; simp

protected lemma naturality (f : α → F β) (x : t' α) :
  η (equiv.traverse eqv f x) = equiv.traverse eqv (@η _ ∘ f) x :=
by simp only [equiv.traverse] with functor_norm

/-- The fact that `t` is a lawful traversable functor carries over the
equivalences to `t'`, with the traversable functor structure given by
`equiv.traversable`. -/
protected def is_lawful_traversable :
  @is_lawful_traversable t' (equiv.traversable eqv) :=
{ to_is_lawful_functor := @equiv.is_lawful_functor _ _ eqv _ _,
  id_traverse := @equiv.id_traverse _ _,
  comp_traverse := @equiv.comp_traverse _ _,
  traverse_eq_map_id := @equiv.traverse_eq_map_id _ _,
  naturality := @equiv.naturality _ _ }

/-- If the `traversable t'` instance has the properties that `map`,
`map_const`, and `traverse` are equal to the ones that come from
carrying the traversable functor structure from `t` over the
equivalences, then the the fact `t` is a lawful traversable functor
carries over as well. -/
protected def is_lawful_traversable' [_i : traversable t']
  (h₀ : ∀ {α β} (f : α → β),
         map f = equiv.map eqv f)
  (h₁ : ∀ {α β} (f : β),
         map_const f = (equiv.map eqv ∘ function.const α) f)
  (h₂ : ∀ {F : Type u → Type u} [applicative F],
        by exactI ∀ [is_lawful_applicative F]
          {α β} (f : α → F β),
         traverse f = equiv.traverse eqv f) :
  _root_.is_lawful_traversable t' :=
begin
    -- we can't use the same approach as for `is_lawful_functor'` because
    -- h₂ needs a `is_lawful_applicative` assumption
  refine {to_is_lawful_functor :=
    equiv.is_lawful_functor' eqv @h₀ @h₁, ..}; introsI,
  { rw [h₂, equiv.id_traverse], apply_instance },
  { rw [h₂, equiv.comp_traverse f g x, h₂], congr,
    rw [h₂], all_goals { apply_instance } },
  { rw [h₂, equiv.traverse_eq_map_id, h₀]; apply_instance },
  { rw [h₂, equiv.naturality, h₂]; apply_instance }
end

end equiv
end equiv


import morphisms.basic
import algebraic_geometry.surjective_on_stalks

/-!

# Locally closed immersions

A morphism of schemes is a closed immersion if the underlying map is a closed embedding, and
the sheaf map is locally surjective.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

/-- A morphism `is_preimmersion` if the underlying map is an topological embedding, and
the map on stalks is surjective. -/
@[mk_iff]
class is_preimmersion (f : X ⟶ Y) : Prop :=
(base_embedding [] : embedding f.1.base)
(stalk_map_surjective [] : ∀ x, function.surjective (PresheafedSpace.stalk_map f.1 x))

instance [is_preimmersion f] [is_preimmersion g] : is_preimmersion (f ≫ g) :=
begin
  constructor,
  { exact (is_preimmersion.base_embedding g).comp (is_preimmersion.base_embedding f) },
  { intro x, erw PresheafedSpace.stalk_map.comp f.1 g.1 x,
    exact (is_preimmersion.stalk_map_surjective f _).comp
      (is_preimmersion.stalk_map_surjective g _) }
end

instance is_open_immersion.to_is_preimmersion [is_open_immersion f] : is_preimmersion f :=
begin
  constructor,
  { exact (is_open_immersion.base_open f).to_embedding },
  { exact λ x, (as_iso $ PresheafedSpace.stalk_map f.1 x).CommRing_iso_to_ring_equiv.surjective }
end

lemma is_preimmersion.of_comp [is_preimmersion (f ≫ g)] :
  is_preimmersion f :=
begin
  constructor,
  { exact embedding_of_embedding_compose f.1.base.2 g.1.base.2
      (is_preimmersion.base_embedding $ f ≫ g) },
  { intro x,
    have := (is_preimmersion.stalk_map_surjective $ f ≫ g) x,
    erw PresheafedSpace.stalk_map.comp at this,
    rw coe_comp at this,
    exact function.surjective.of_comp this }
end

universes w v

lemma Top.sheaf.hom_stalk_ext {X : Top.{v}} {C : Type u} [category.{v} C]
  [concrete_category.{v} C] [has_colimits C]
  [preserves_filtered_colimits (forget C)]
  [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]
  {F G : X.sheaf C}
  (α β : F ⟶ G)
  (h : ∀ x, (Top.presheaf.stalk_functor C x).map α.1 = (Top.presheaf.stalk_functor C x).map β.1) :
  α = β :=
begin
  ext U,
  induction U,
  apply concrete_category.hom_ext,
  intros s,
  apply Top.presheaf.section_ext G U,
  intro x,
  rw [← Top.presheaf.stalk_functor_map_germ_apply, ← Top.presheaf.stalk_functor_map_germ_apply, h],
end

lemma SheafedSpace.hom_stalk_ext {C : Type u} [category.{v} C]
  [concrete_category.{v} C] [has_colimits C]
  [preserves_filtered_colimits (forget C)]
  [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]
  {X Y : SheafedSpace C}
  (f g : X ⟶ Y)
  (h : f.base = g.base)
  (h' : ∀ x, PresheafedSpace.stalk_map f x =
    Y.presheaf.stalk_specializes (specializes_of_eq $ by rw h) ≫ PresheafedSpace.stalk_map g x) :
  f = g :=
begin
  cases f, cases g,
  obtain (rfl : f_base = g_base) := h,
  suffices : f_c = g_c, { subst this },
  ext U,
  induction U,
  apply concrete_category.hom_ext,
  intros s,
  apply Top.presheaf.section_ext X.sheaf ((opens.map f_base).obj U),
  intro x,
  delta SheafedSpace.sheaf Top.sheaf.presheaf,
  dsimp only,
  erw [← PresheafedSpace.stalk_map_germ_apply ⟨f_base, f_c⟩,
    ← PresheafedSpace.stalk_map_germ_apply ⟨f_base, g_c⟩, h'],
  simp only [Top.presheaf.stalk_specializes_refl, category.id_comp,
    PresheafedSpace.stalk_map_germ_apply],
end

lemma SheafedSpace.mono_of_base_injective_of_stalk_epi
  {C : Type u} [category.{v} C]
  [concrete_category.{v} C] [has_colimits C]
  [preserves_filtered_colimits (forget C)]
  [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]
  {X Y : SheafedSpace C}
  (f : X ⟶ Y)
  (h₁ : function.injective f.base)
  (h₂ : ∀ x, epi (PresheafedSpace.stalk_map f x)) : mono f :=
begin
  constructor,
  introsI Z g h e,
  have : g.base = h.base,
  { rw ← Top.mono_iff_injective at h₁, resetI,
    simp only [← cancel_mono f.base, ← SheafedSpace.comp_base, e] },
  apply SheafedSpace.hom_stalk_ext _ _ this,
  intro x,
  cases g, cases h, obtain (rfl : g_base = h_base) := this,
  rw [← cancel_epi (PresheafedSpace.stalk_map f (g_base x)), Top.presheaf.stalk_specializes_refl,
  category.id_comp],
  rw [← PresheafedSpace.stalk_map.comp ⟨g_base, g_c⟩ f,
    ← PresheafedSpace.stalk_map.comp ⟨g_base, h_c⟩ f],
  congr, exact e,
end

instance is_preimmersion.to_mono [is_preimmersion f] : mono f :=
begin
  refine (Scheme.forget_to_LocallyRingedSpace ⋙
    LocallyRingedSpace.forget_to_SheafedSpace).mono_of_mono_map _,
  apply SheafedSpace.mono_of_base_injective_of_stalk_epi,
  { exact (is_preimmersion.base_embedding f).inj },
  { intro x,
    apply (forget CommRing).epi_of_epi_map,
    rw epi_iff_surjective,
    exact (is_preimmersion.stalk_map_surjective f x : _) }
end

lemma is_preimmersion_stable_under_composition :
  morphism_property.stable_under_composition @is_preimmersion :=
λ _ _ _ _ _ _ _, by exactI infer_instance

lemma is_preimmersion_respects_iso :
  morphism_property.respects_iso @is_preimmersion :=
is_preimmersion_stable_under_composition.respects_iso (λ _ _ _, infer_instance)

lemma is_preimmersion_is_local_at_target :
  property_is_local_at_target @is_preimmersion :=
begin
  constructor,
  { exact is_preimmersion_respects_iso },
  { introsI X Y f U H,
    constructor,
    { rw morphism_restrict_val_base, exact H.1.restrict_preimage U.1 },
    { exact λ x, ((morphism_property.surjective_respects_iso _).arrow_iso_iff
      (morphism_restrict_stalk_map f U x)).mpr (H.2 x.1) } },
  { intros X Y f 𝒰 H,
    constructor,
    { apply (embedding_iff_embedding_of_supr_eq_top
        𝒰.supr_opens_range f.1.base.2).mpr,
      intro i,
      have := ((is_preimmersion_respects_iso.arrow_iso_iff
        (morphism_restrict_opens_range f (𝒰.map i))).mpr (H i)).1,
      rwa [arrow.mk_hom, morphism_restrict_val_base] at this },
    { exact λ x, ((morphism_property.surjective_respects_iso _).arrow_iso_iff
        (morphism_restrict_stalk_map f _ _)).mp
        (((is_preimmersion_respects_iso.arrow_iso_iff (morphism_restrict_opens_range f (𝒰.map _)))
        .mpr (H (𝒰.f $ f.1.base x))).2 ⟨x, 𝒰.covers (f.1.base x)⟩) } }
end

lemma is_preimmersion_open_cover_tfae (f : X ⟶ Y) :
  tfae [is_preimmersion f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      is_preimmersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      is_preimmersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), is_preimmersion (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      is_preimmersion (pullback.snd : pullback f g ⟶ U),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤),
      (∀ i, is_preimmersion (f ∣_ (U i)))] :=
is_preimmersion_is_local_at_target.open_cover_tfae f

lemma is_preimmersion_stable_under_base_change :
  morphism_property.stable_under_base_change @is_preimmersion :=
morphism_property.stable_under_base_change.mk is_preimmersion_respects_iso
begin
  intros X Y S f g hg,
  refine ⟨_, pullback_snd_surjective_on_stalks f g hg.2⟩,
  rw ← (pullback_comparison_comp_fst Scheme.forget_to_Top f g).trans (Scheme.forget_to_Top_map' _),
  exact (Top.fst_embedding_of_right_embedding f.1.base hg.1).comp
    (embedding_category_theory_pullback_comparison_of_surjective_on_stalks f g hg.2)
end

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_preimmersion g] :
  is_preimmersion (pullback.fst : pullback f g ⟶ X) :=
is_preimmersion_stable_under_base_change.fst f g infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_preimmersion f] :
  is_preimmersion (pullback.snd : pullback f g ⟶ Y) :=
is_preimmersion_stable_under_base_change.snd f g infer_instance

lemma is_preimmersion_Spec_of_exists_eq_div {R S : CommRing} (f : R ⟶ S)
  (hf : ∀ x : S, ∃ a b : R, is_unit (f b) ∧ x * f b = f a) :
  is_preimmersion (Scheme.Spec.map f.op) :=
begin
  constructor,
  { have H : ∀ x : (is_unit.submonoid S).comap f, is_unit (f x) := subtype.prop,
    have : (is_localization.lift H).comp (algebra_map R $ localization $
      (is_unit.submonoid S).comap f) = f := is_localization.lift_comp H,
    rw [Scheme.Spec_map_val_base, ← this, prime_spectrum.comap_comp],
    refine (prime_spectrum.localization_comap_embedding (localization $
      (is_unit.submonoid S).comap f) ((is_unit.submonoid S).comap f)).comp
      (prime_spectrum.closed_embedding_comap_of_surjective _ _ _).to_embedding,
    rintro (x : S),
    obtain ⟨a, b, hb, e⟩ := hf x,
    refine ⟨is_localization.mk' _ a ⟨b, show b ∈ ((is_unit.submonoid S).comap f), from hb⟩, _⟩,
    rwa [is_localization.lift_mk'_spec, subtype.coe_mk, eq_comm, mul_comm] },
  { intro x,
    refine ((morphism_property.surjective_respects_iso CommRing).arrow_mk_iso_iff
      (Spec.stalk_map_iso _ x)).mpr _,
    exact ring_hom.surjective_on_stalks_of_exists_eq_div hf x.as_ideal }
end

attribute [reassoc] Top.presheaf.germ_res

instance (x) : is_preimmersion (X.from_Spec_stalk x) :=
begin
  delta Scheme.from_Spec_stalk is_affine_open.from_Spec_stalk,
  apply is_preimmersion_stable_under_composition,
  { apply is_preimmersion_Spec_of_exists_eq_div,
    rintro (y : X.presheaf.stalk x),
    let R := X.affine_cover_ring x,
    obtain ⟨x' : prime_spectrum R, hx⟩ := X.affine_cover.covers x,
    let e : X.presheaf.stalk x ≅ (Spec.structure_sheaf R).presheaf.stalk x' :=
      X.presheaf.stalk_congr (inseparable.of_eq hx.symm)
        ≪≫ (as_iso $ PresheafedSpace.stalk_map (X.affine_cover.map x).1 x'),
    let e' : R ≅ X.presheaf.obj (op $ (X.affine_cover.map x).opens_range) :=
      (as_iso $ to_Spec_Γ R) ≪≫ (as_iso $ (X.affine_cover.is_open x).inv_app ⊤) ≪≫
        X.presheaf.map_iso (eq_to_iso $ opens.ext $ by exact set.image_univ.symm).op,
    have : e'.hom ≫ X.presheaf.germ ⟨x, X.affine_cover.covers x⟩ ≫ e.hom =
      structure_sheaf.to_stalk R x',
    { simp only [iso.trans_hom, category.assoc, as_iso_hom, functor.map_iso_hom,
        Top.presheaf.stalk_congr_hom, iso.op_hom, Top.presheaf.germ_res_assoc,
        Top.presheaf.germ_stalk_specializes'_assoc, structure_sheaf.to_stalk],
      erw [PresheafedSpace.stalk_map_germ', PresheafedSpace.is_open_immersion.inv_app_app_assoc],
      congr' 1,
      refine (X.affine_cover.obj x).presheaf.germ_res (eq_to_hom _) ⟨_, _⟩,
      exact opens.map_functor_eq' _ (is_open_immersion.base_open _) _ },
    obtain ⟨⟨z, s⟩, hz⟩ := is_localization.surj x'.as_ideal.prime_compl (e.hom y),
    refine ⟨e'.hom z, e'.hom s, _, _⟩,
    { apply is_unit_of_map_unit e.hom, simp only [← comp_apply, category.assoc], erw this,
      exact is_localization.map_units ((Spec.structure_sheaf R).presheaf.stalk x') s },
    { apply (show function.injective e.hom, from e.CommRing_iso_to_ring_equiv.injective),
      simp only [← comp_apply, category.assoc, map_mul, iso.CommRing_iso_to_ring_equiv],
      erw this,
      exact hz } },
  { apply_instance }
end

end algebraic_geometry


-- liftedCIA: Variability-aware Change Impact Assessment
import .cia
import .variability

open CIA
open variability

namespace liftedCIA

def Annotation' := Var Annotation
def SysEl' := Var SysEl
def GSNEl' := Var GSNEl

def Sys' : Type := set' SysEl
def GSN' : Type := set' GSNEl

def TraceRel' := set' (SysEl × GSNEl)

open variability.has_index

def indexTraceRel (t: TraceRel') (pc : PC) : set (SysEl × GSNEl) :=
    index t pc

instance TraceRel_has_index : has_index TraceRel' :=
⟨ indexTraceRel ⟩

constant sliceSys'   (s : Sys')  (es : set' SysEl) : Sys'
constant sliceGSN_V' (ac : GSN') (es : set' GSNEl) : GSN'
constant sliceGSN_R' (ac : GSN') (es : set' GSNEl) : GSN'

axiom sliceSys_correct : ∀ (s : Sys')  (es : set' SysEl) (pc : PC),
index (sliceSys' s es) pc = sliceSys (index s pc) (index es pc)

axiom sliceGSNV_correct : ∀ (ac : GSN')  (es : set' GSNEl) (pc : PC),
index (sliceGSN_V' ac es) pc = sliceGSN_V (index ac pc) (index es pc)

axiom sliceGSNR_correct : ∀ (ac : GSN')  (es : set' GSNEl) (pc : PC),
index (sliceGSN_R' ac es) pc = sliceGSN_R (index ac pc) (index es pc)

structure Delta' :=
mk :: (add : set' SysEl) (delete : set' SysEl) (modify : set' SysEl)

open variability.has_index

def indexDelta (d : Delta') (pc : PC) :=
    let a := index d.add pc,
        l := index d.delete pc,
        m := index d.modify pc
    in  Delta.mk a l m

instance Delta_has_index : has_index Delta' :=
⟨ indexDelta ⟩

def restrict' (t : TraceRel') (d : Delta') : TraceRel' :=
    let relevant := d.add ∪ d.delete ∪ d.modify
    in  λ x, t x ∧ relevant x.1

theorem restrict_correct : ∀ (pc : PC) (t : TraceRel') (d : Delta'),
    index (restrict' t d) pc = restrict (index t pc) (indexDelta d pc)
    :=
begin
    intros,
    rw restrict, rw indexDelta, simp,
    repeat {rw index}, repeat {rw function.comp},
    unfold has_mem.mem, unfold set.mem,
    apply funext, intros,
    repeat {rw ←and_or_distrib_left}, rw ←and_assoc, rw ←and_comm pc,
    rw ←and_assoc, rw and_self pc, rw and_assoc, rw ←and.rotate,
    rw restrict', simp, rw ←and_assoc, rw and_comm pc,
    unfold has_union.union, repeat {rw variability.union}, simp,
    rw and_assoc
end

def trace' (t : TraceRel') (es : set' SysEl) : set' GSNEl :=
    λ (g:GSNEl), ∃ (s : SysEl) , es s ∧ t ⟨s , g⟩

theorem trace_correct : ∀ (t : TraceRel') (es : set' SysEl) (pc : PC),
    index (trace' t es) pc = trace (index t pc) (index es pc)
    :=
begin
    intros, repeat {rw index}, repeat {rw function.comp},
    rw trace', rw CIA.trace, simp, funext, simp,
    unfold has_mem.mem, rw ←exists_and_distrib_left, split,
        intro h, cases h with x h₁, existsi x, repeat {rw set.mem},
            rw and.left_comm, rw and.assoc, rw ←and.assoc, rw and_self,
            apply h₁,
        intro h, cases h with x h₁, existsi x, repeat {rw set.mem at h₁},
            rw and.left_comm at h₁, rw and.assoc at h₁, rw ←and.assoc at h₁,
            rw and_self at h₁, exact h₁
end

def createAnnotation'   (g : GSN')
                        (recheck : set' GSNEl)
                        (revise : set' GSNEl)
                    : set' (GSNEl × Annotation) :=
    let ch := image (λ e, (e, Annotation.Recheck)) recheck,
        rv := image (λ e, (e, Annotation.Revise)) revise,
        n  := image (λ e, (e, Annotation.Reuse)) (g - (recheck ∪ revise))
    in  ch ∪ rv ∪ n

theorem createAnnotation_correct:
    ∀ (g : GSN') (recheck : set' GSNEl) (revise : set' GSNEl) (pc : PC),
    index (createAnnotation' g recheck revise) pc =
    createAnnotation (index g pc) (index recheck pc) (index revise pc)
    :=
begin
    intros, repeat {rw index}, repeat {rw function.comp},
    rw createAnnotation, rw createAnnotation', simp,
    repeat {rw image}, repeat {rw set.union_def}, simp, unfold has_sdiff.sdiff,
    rw set.diff, simp, funext, simp,
    repeat {rw image}, repeat {rw set.union_def}, simp,
    repeat {rw set.union_def}, dsimp,
    repeat {rw set.mem_def},
end

open Delta'

def GSN_IA' (S S' : Sys')
            (A  : GSN')
            (R  : TraceRel')
            (D  : Delta')
            : set' (GSNEl × Annotation) :=
    let R'          := restrict' R D,
        C1dm        := sliceSys' S (D.delete ∪ D.modify),
        C1am        := sliceSys' S' (D.add ∪ D.modify),
        C2Recheck   := (trace' R C1dm) ∪ (trace' R' C1am),
        C2Revise    := trace' R D.delete,
        C3Recheck1  := sliceGSN_V' A C2Revise,
        C3Recheck2  := sliceGSN_R' A (C2Recheck ∪ C3Recheck1)
    in  createAnnotation' A C3Recheck2 C2Revise

universe u
variables {α β γ : Type}

open set
open variability
open variability.has_index

lemma index_union : ∀ {α : Type _} (s₁ s₂ : set' α) (pc : PC),
(index (s₁ ∪ s₂) pc) = (index s₁ pc) ∪ (index s₂ pc) :=
begin
    intros, unfold has_union.union, unfold variability.union, unfold set.union,
    unfold has_mem.mem, unfold set.mem,
    rw index, rw index, rw index,
    rw function.comp, rw function.comp, rw function.comp, simp,
    apply funext, intro,
    rw and_or_distrib_left, refl
end

theorem GSN_IA'_correct :
    ∀ (S S' : Sys') (A  : GSN') (R  : TraceRel') (D : Delta') (pc : PC),
    (GSN_IA' S S' A R D) | pc = GSN_IA  (S | pc) (S' | pc) (A | pc) (R | pc) (D | pc)
    :=
begin
    intros, rw GSN_IA', rw GSN_IA, simp,
    rw← restrict_correct, rw indexDelta, simp,
    rw ←index_union, rw ←index_union, rw← sliceSys_correct,
    rw← trace_correct, rw← trace_correct, rw← sliceSys_correct,
    rw← trace_correct, rw← sliceGSNV_correct, rw ←index_union,
    rw ←index_union, rw← sliceGSNR_correct, rw← createAnnotation_correct
end

end liftedCIA


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison, Jakob von Raumer
-/
import algebra.homology.quasi_iso
import category_theory.abelian.homology
import category_theory.preadditive.projective_resolution
import category_theory.preadditive.yoneda.limits
import category_theory.preadditive.yoneda.projective

/-!
# Abelian categories with enough projectives have projective resolutions

When `C` is abelian `projective.d f` and `f` are exact.
Hence, starting from an epimorphism `P ⟶ X`, where `P` is projective,
we can apply `projective.d` repeatedly to obtain a projective resolution of `X`.
-/

noncomputable theory

open category_theory
open category_theory.limits
open opposite

universes v u v' u'

namespace category_theory

open category_theory.projective

variables {C : Type u} [category.{v} C] [abelian C]

/--
When `C` is abelian, `projective.d f` and `f` are exact.
-/
lemma exact_d_f [enough_projectives C] {X Y : C} (f : X ⟶ Y) : exact (d f) f :=
(abelian.exact_iff _ _).2 $
  ⟨by simp, zero_of_epi_comp (π _) $ by rw [←category.assoc, cokernel.condition]⟩

/-- The preadditive Co-Yoneda functor on `P` preserves colimits if `P` is projective. -/
def preserves_finite_colimits_preadditive_coyoneda_obj_of_projective (P : C)
  [hP : projective P] : preserves_finite_colimits (preadditive_coyoneda_obj (op P)) :=
begin
  letI := (projective_iff_preserves_epimorphisms_preadditive_coyoneda_obj' P).mp hP,
  apply functor.preserves_finite_colimits_of_preserves_epis_and_kernels,
end

/-- An object is projective if its preadditive Co-Yoneda functor preserves finite colimits. -/
lemma projective_of_preserves_finite_colimits_preadditive_coyoneda_obj (P : C)
  [hP : preserves_finite_colimits (preadditive_coyoneda_obj (op P))] : projective P :=
begin
  rw projective_iff_preserves_epimorphisms_preadditive_coyoneda_obj',
  apply_instance
end

namespace ProjectiveResolution

/-!
Our goal is to define `ProjectiveResolution.of Z : ProjectiveResolution Z`.
The `0`-th object in this resolution will just be `projective.over Z`,
i.e. an arbitrarily chosen projective object with a map to `Z`.
After that, we build the `n+1`-st object as `projective.syzygies`
applied to the previously constructed morphism,
and the map to the `n`-th object as `projective.d`.
-/
variables [enough_projectives C]

/-- Auxiliary definition for `ProjectiveResolution.of`. -/
@[simps]
def of_complex (Z : C) : chain_complex C ℕ :=
chain_complex.mk'
  (projective.over Z) (projective.syzygies (projective.π Z)) (projective.d (projective.π Z))
  (λ ⟨X, Y, f⟩, ⟨projective.syzygies f, projective.d f, (exact_d_f f).w⟩)

/--
In any abelian category with enough projectives,
`ProjectiveResolution.of Z` constructs a projective resolution of the object `Z`.
-/
@[irreducible] def of (Z : C) : ProjectiveResolution Z :=
{ complex := of_complex Z,
  π := chain_complex.mk_hom _ _ (projective.π Z) 0
    (by { simp, exact (exact_d_f (projective.π Z)).w.symm, })
    (λ n _, ⟨0, by ext⟩),
  projective := by { rintros (_|_|_|n); apply projective.projective_over, },
  exact₀ := by simpa using exact_d_f (projective.π Z),
  exact := by { rintros (_|n); { simp, apply exact_d_f, }, },
  epi := projective.π_epi Z, }

@[priority 100]
instance (Z : C) : has_projective_resolution Z :=
{ out := ⟨of Z⟩ }

@[priority 100]
instance : has_projective_resolutions C :=
{ out := λ Z, by apply_instance }

end ProjectiveResolution
end category_theory
namespace homological_complex.hom

variables {C : Type u} [category.{v} C] [abelian C]

/-- If `X` is a chain complex of projective objects and we have a quasi-isomorphism `f : X ⟶ Y[0]`,
then `X` is a projective resolution of `Y.` -/
def to_single₀_ProjectiveResolution {X : chain_complex C ℕ} {Y : C}
  (f : X ⟶ (chain_complex.single₀ C).obj Y) [quasi_iso f]
  (H : ∀ n, projective (X.X n)) :
  ProjectiveResolution Y :=
{ complex := X,
  π := f,
  projective := H,
  exact₀ := f.to_single₀_exact_d_f_at_zero,
  exact := f.to_single₀_exact_at_succ,
  epi := f.to_single₀_epi_at_zero }

end homological_complex.hom


import GMLInit.Data.Basic
import GMLInit.Data.Equiv
import GMLInit.Data.Ord
import GMLInit.Meta.Basic
import GMLInit.Meta.Decidable
import GMLInit.Meta.Relation

namespace Index

instance {α} (a : α) (as : List α) : Inhabited (Index (a :: as)) := ⟨head⟩

protected abbrev recNilOn {α} {motive : Index ([]:List α) → Sort _} (i : Index ([]:List α)) : motive i := nomatch i

protected abbrev casesNilOn {α} {motive : Index ([]:List α) → Sort _} (i : Index ([]:List α)) : motive i := nomatch i

lemma val_head {α} (a : α) (as : List α) : (@head α a as).val = a := rfl

lemma val_tail {α} (a : α) (as : List α) (i : Index as) : (@tail α a as i).val = i.val := rfl

lemma val_ndrec {xs ys : List α} (i : Index xs) : (h : xs = ys) → val (h ▸ i : Index ys) = i.val | rfl => rfl

protected def compare : Index xs → Index xs → Ordering
| head, head => .eq
| head, tail _ => .lt
| tail _, head => .gt
| tail i, tail j => Index.compare i j

instance instOrd (xs : List α) : Ord (Index xs) := ⟨Index.compare⟩

instance instLinearOrd : (xs : List α) → LinearOrd (Index xs)
| [] => {
  symm := (nomatch .)
  le_trans := (nomatch .)
  eq_strict := (nomatch .)
}
| _::xs => {
  symm := fun
  | head, head => rfl
  | head, tail _ => rfl
  | tail _, head => rfl
  | tail i, tail j => (instLinearOrd xs).symm i j
  le_trans := fun {i j k} hij hjk => match i, j, k, hij, hjk with
  | head, _, head, _, _ => Ordering.noConfusion
  | head, _, tail _, _, _ => Ordering.noConfusion
  | tail _, head, tail _, h, _ => absurd rfl h
  | tail _, tail _, tail _, hij, hjk => (instLinearOrd xs).le_trans hij hjk
  eq_strict := fun {i j} h => match i, j, h with
  | head, head, _ => rfl
  | head, tail _, h => Ordering.noConfusion h
  | tail _, head, h => Ordering.noConfusion h
  | tail _, tail _, h => congrArg tail ((instLinearOrd xs).eq_strict h)
}

instance : LE (Index xs) := ⟨fun i j => Ord.compare i j ≠ .gt⟩

instance : LT (Index xs) := ⟨fun i j => Ord.compare i j = .lt⟩

protected def head? {α} : (as : List α) → Option (Index as)
| [] => none
| _::_ => some head

protected def last? {α} : (as : List α) → Option (Index as)
| [] => none
| _::as =>
  match Index.last? as with
  | some i => some (tail i)
  | none => some head

protected def next? {α} : {as : List α} → Index as → Option (Index as)
| _::as, head => Option.map tail (Index.head? as)
| _::_, tail i => Option.map tail (Index.next? i)

protected def pred? {α} : {as : List α} → Index as → Option (Index as)
| _::_, head => none
| _::_, tail i =>
  match Index.pred? i with
  | some i => some (tail i)
  | none => some head

protected def find? {α} : {xs : List α} → (p : Index xs → Bool) → Option (Index xs)
| [], _ => none
| _::_, p =>
  match p head, Index.find? (λ i => p (tail i)) with
  | true, _ => some head
  | false, some i => some (tail i)
  | false, none => none

theorem find_some {α} {xs : List α} {p : Index xs → Bool} (i : Index xs) : Index.find? p = some i → p i = true := by
  induction xs with
  | nil => cases i
  | cons x xs ih =>
    intro h
    clean unfold Index.find? at h
    clean at h
    split at h
    next hh => injection h with h; rw [←h, hh]
    next ht => injection h with h; rw [←h, ih _ ht]
    next => contradiction

theorem find_none {α} {xs : List α} {p : Index xs → Bool} (i : Index xs) : Index.find? p = none → p i = false := by
  induction xs with
  | nil => cases i
  | cons x xs ih =>
    intro h
    clean unfold Index.find? at h
    clean at h
    split at h
    next => contradiction
    next => contradiction
    next hh ht =>
      cases i with
      | head => exact hh
      | tail i => exact ih _ ht

def search {α} {xs : List α} {p : Index xs → Prop} [DecidablePred p] (h : ∃ i, p i) : Index xs :=
  match hi : Index.find? λ i => p i with
  | some i => i
  | none => absurd h $ by
    intro ⟨j, hj⟩
    have := find_none j hi
    rw [decide_eq_true hj] at this
    contradiction

theorem search_prop {α} {xs : List α} {p : Index xs → Prop} [DecidablePred p] (h : ∃ i, p i) : p (search h) := by
  clean unfold search
  split
  next h =>
    apply of_decide_eq_true
    exact find_some _ h
  next f =>
    absurd h
    intro ⟨j, hj⟩
    have := find_none j f
    rw [decide_eq_true hj] at this
    contradiction

theorem search_eq {α} {xs : List α} {p q : Index xs → Prop} [ip : DecidablePred p] [iq : DecidablePred q] {hp : ∃ i, p i} {hq : ∃ j, q j}  (h : p = q) : search hp = search hq := by
  cases h
  cases Subsingleton.elim ip iq
  cases Subsingleton.elim hp hq
  rfl

theorem search_ext {α} {xs : List α} {p q : Index xs → Prop} [DecidablePred p] [DecidablePred q] {hp : ∃ i, p i} {hq : ∃ j, q j} : (∀ i, p i ↔ q i) → search hp = search hq := by
  intro h
  apply search_eq
  funext i
  exact propext (h i)

@[inline]
def toNatTR {α} {xs : List α} (i : Index xs) : Nat :=
  let rec loop : {xs : List α} → Index xs → Nat → Nat
  | _, .head, n => n
  | _, .tail i, n => loop i (n+1)
  loop i 0

@[implemented_by toNatTR]
protected def toNat {α} : {xs : List α} → (i : Index xs) → Nat
| _, head => 0
| _, tail i => Index.toNat i + 1

theorem toNat_lt_length {α} {xs : List α} (i : Index xs) : i.toNat < xs.length := by
  induction xs with
  | nil => cases i
  | cons x xs ih =>
    cases i with
    | head =>
      exact Nat.zero_lt_succ ..
    | tail i =>
      apply Nat.succ_lt_succ
      exact ih ..

protected abbrev toFin {α} {xs : List α} (i : Index xs) : Fin xs.length := ⟨i.toNat, i.toNat_lt_length⟩

def ofFinTR {α} {xs : List α} (i : Fin xs.length) : Index xs :=
  let rec loop : {xs ys : List α} → Sum (Fin xs.length) (Index ys) → Index (List.reverseAux xs ys)
  | [], _, .inr i => i
  | _ :: _, _, .inr i => loop (ys:=_::_) (.inr (.tail i))
  | _ :: _, _, .inl ⟨0, _⟩ => loop (ys:=_::_) (.inr .head)
  | _ :: _, _, .inl ⟨i+1, hi⟩ => loop (ys:=_::_) (.inl ⟨i, Nat.lt_of_succ_lt_succ hi⟩)
  xs.reverse_reverse ▸ loop (ys:=[]) (.inl ⟨i.val, xs.length_reverse.symm ▸ i.isLt⟩)

@[implemented_by ofFinTR]
protected def ofFin {α} : {xs : List α} → Fin xs.length → Index xs
| _::_, ⟨0,_⟩ => head
| _::_, ⟨i+1,h⟩ => tail (Index.ofFin ⟨i, Nat.lt_of_succ_lt_succ h⟩)

theorem ofFin_toFin {α} {xs : List α} (i : Index xs) : Index.ofFin i.toFin = i := by
  induction xs with
  | nil => cases i
  | cons x xs ih =>
    cases i with
    | head => rfl
    | tail i =>
      apply congrArg tail
      exact ih ..

theorem toNat_ofFin {α} {xs : List α} (i : Fin xs.length) : (Index.ofFin i).toNat = i.val := by
  induction xs with
  | nil => cases i; contradiction
  | cons x xs ih =>
    match i with
    | ⟨0,_⟩ => rfl
    | ⟨i+1,h⟩ =>
      apply congrArg Nat.succ
      rw [ih]; rfl

theorem toFin_ofFin {α} {xs : List α} (i : Fin xs.length) : (Index.ofFin i).toFin = i := by
  apply Fin.eq_of_val_eq
  apply toNat_ofFin

def equivFin {α} (xs : List α) : Equiv (Index xs) (Fin xs.length) where
  fwd := Index.toFin
  rev := Index.ofFin
  spec {_ _} := by
    constr
    · intro | rfl => exact ofFin_toFin ..
    · intro | rfl => exact toFin_ofFin ..

theorem val_ofFin_eq_get {α} (xs : List α) (i : Fin xs.length) : (Index.ofFin i).val = xs.get i := by
  induction xs with
  | nil => cases i; contradiction
  | cons x xs ih =>
    match i with
    | ⟨0, _⟩ => rfl
    | ⟨i+1, hi⟩ =>
      unfold Index.ofFin
      rw [val_tail, ih]
      rfl

end Index


import Lbar.ext_preamble

noncomputable theory

universes u v

open opposite category_theory category_theory.limits
open_locale nnreal zero_object

variables (r r' : ℝ≥0)
variables [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r < 1)] [fact (r' < 1)]

open bounded_homotopy_category

variables (BD : breen_deligne.data)
variables (κ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
variables [∀ (c : ℝ≥0), BD.suitable (κ c)] [∀ n, fact (monotone (function.swap κ n))]
variables [∀ (c : ℝ≥0), BD.suitable (κ₂ c)] [∀ n, fact (monotone (function.swap κ₂ n))]
variables (M : ProFiltPseuNormGrpWithTinv₁.{u} r')
variables (V : SemiNormedGroup.{u}) [complete_space V] [separated_space V]

def ExtQprime_iso_aux_system_obj_aux' (X : Profinite.{u}) :
  Ab.ulift.{u+1}.obj
    ((forget₂ SemiNormedGroup Ab).obj
      (SemiNormedGroup.Completion.obj ((SemiNormedGroup.LocallyConstant.obj V).obj (op X)))) ≅
  (forget₂ SemiNormedGroup.{u+1} Ab.{u+1}).obj
    (SemiNormedGroup.Completion.obj
      ((SemiNormedGroup.LocallyConstant.obj (SemiNormedGroup.ulift.{u+1}.obj V)).obj (op X))) :=
begin
  refine add_equiv.to_AddCommGroup_iso _,
  refine add_equiv.ulift.trans _,
  refine add_equiv.mk _ _ _ _ _,
  { refine normed_group_hom.completion _,
    refine locally_constant.map_hom _,
    refine { bound' := ⟨1, λ v, _⟩, .. add_equiv.ulift.symm },
    rw one_mul, exact le_rfl },
  { refine uniform_space.completion.map _,
    refine locally_constant.map_hom _,
    refine { bound' := ⟨1, λ v, _⟩, .. add_equiv.ulift },
    rw one_mul, exact le_rfl },
  { erw [function.left_inverse_iff_comp, uniform_space.completion.map_comp],
    { have : ulift.down.{u+1} ∘ ulift.up.{u+1} = (id : V → V) := rfl,
      erw [locally_constant.map_comp, this, locally_constant.map_id, uniform_space.completion.map_id] },
    { apply normed_group_hom.uniform_continuous, },
    { apply normed_group_hom.uniform_continuous, } },
  { erw [function.right_inverse_iff_comp, uniform_space.completion.map_comp],
    { have : ulift.up.{u+1 u} ∘ ulift.down.{u+1} = @id (ulift V) := by { ext v, refl },
      erw [locally_constant.map_comp, this, locally_constant.map_id, uniform_space.completion.map_id] },
    { apply normed_group_hom.uniform_continuous, },
    { apply normed_group_hom.uniform_continuous, } },
  { intros x y, apply normed_group_hom.map_add, }
end
.

attribute [simps] equiv.ulift add_equiv.ulift

lemma SemiNormedGroup.forget₂_Ab_map {V W : SemiNormedGroup} (f : V ⟶ W) :
  (forget₂ SemiNormedGroup Ab).map f = f.to_add_monoid_hom :=
rfl

lemma SemiNormedGroup.forget₂_Ab_obj (V : SemiNormedGroup) :
  (forget₂ SemiNormedGroup Ab).obj V = AddCommGroup.of V :=
rfl

set_option pp.universes true

--jmc: is this helpful??
@[reassoc]
lemma ExtQprime_iso_aux_system_obj_aux'_natural (X Y : Profinite.{u}) (f : X ⟶ Y) :
  (ExtQprime_iso_aux_system_obj_aux' V Y).hom ≫
    (forget₂ _ _).map (SemiNormedGroup.Completion.map ((SemiNormedGroup.LocallyConstant.obj _).map f.op)) =
    Ab.ulift.map ((forget₂ _ _).map (SemiNormedGroup.Completion.map ((SemiNormedGroup.LocallyConstant.obj _).map f.op))) ≫
 (ExtQprime_iso_aux_system_obj_aux' V X).hom :=
begin
  ext1 ⟨φ⟩, simp only [comp_apply],
  dsimp only [ExtQprime_iso_aux_system_obj_aux', add_equiv.to_AddCommGroup_iso,
    add_equiv.trans_apply, add_equiv.coe_to_add_monoid_hom, add_equiv.coe_mk,
    Ab.ulift_map_apply,
    SemiNormedGroup.forget₂_Ab_map, SemiNormedGroup.forget₂_Ab_obj,
    AddCommGroup.coe_of],
  apply uniform_space.completion.induction_on φ; clear φ,
  { refine @is_closed_eq _ _ _ _ (id _) _ _ _ _,
    { dsimp [SemiNormedGroup.Completion_obj, SemiNormedGroup.LocallyConstant_obj_obj],
      apply_instance },
    { apply uniform_space.completion.continuous_map.comp uniform_space.completion.continuous_map },
    { apply uniform_space.completion.continuous_map.comp,
      dsimp only [Ab.ulift, add_monoid_hom.coe_mk, add_equiv.ulift_apply,
        equiv.to_fun_as_coe, equiv.ulift_apply],
      apply uniform_space.completion.continuous_map } },
  { intros φ,
    dsimp only [Ab.ulift, add_monoid_hom.coe_mk, add_equiv.ulift_apply,
      equiv.to_fun_as_coe, equiv.ulift_apply,
      SemiNormedGroup.LocallyConstant_obj_map,
      SemiNormedGroup.Completion_map],
    erw [normed_group_hom.completion_coe, normed_group_hom.completion_coe,
      normed_group_hom.completion_coe, normed_group_hom.completion_coe],
    congr' 1,
    dsimp only [locally_constant.comap_hom_apply, locally_constant.map_hom_apply],
    erw [locally_constant.comap_map],
    exact f.continuous, }
end
.

open category_theory.preadditive

lemma FreeAb_naturality_helper {C 𝓐 : Type*} [category C] [category 𝓐] [preadditive 𝓐]
  (F G : FreeAb C ⥤ 𝓐) [F.additive] [G.additive]
  (η : ∀ X : FreeAb C, F.obj X ⟶ G.obj X)
  (hη : ∀ ⦃X Y : C⦄ (f : X ⟶ Y), F.map ((FreeAb.of_functor _).map f) ≫ η _ = η _ ≫ G.map ((FreeAb.of_functor _).map f))
  {X Y : FreeAb C} (f : X ⟶ Y) :
  F.map f ≫ η Y = η X ≫ G.map f :=
begin
  change right_comp _ (η Y) (F.map_add_hom f) = left_comp _ (η X) (G.map_add_hom f),
  rw [← add_monoid_hom.comp_apply, ← add_monoid_hom.comp_apply], congr' 1, clear f,
  ext1 f, cases X, cases Y, exact hη f,
end

lemma ExtQprime_iso_aux_system_obj_aux_aux (X Y : Profinite.{u}) (f : X ⟶ Y) :
  (LCC_iso_Cond_of_top_ab.{u} V).inv.app (op.{u+2} Y) ≫
  (forget₂.{u+1 u+1 u u u} SemiNormedGroup.{u} Ab.{u}).map
    (SemiNormedGroup.Completion.{u}.map
    ((SemiNormedGroup.LocallyConstant.{u u}.obj V).map f.op)) =
  (Condensed.of_top_ab.presheaf _).map f.op ≫
  (LCC_iso_Cond_of_top_ab V).inv.app (op X) :=
begin
  simp only [← nat_iso.app_inv, iso.inv_comp_eq],
  simp only [← category.assoc, iso.eq_comp_inv],
  ext1 t, dsimp [forget₂, has_forget₂.forget₂,
    LCC_iso_Cond_of_top_ab, LCC_iso_Cond_of_top_ab_add_equiv] at t ⊢,
  simp only [comp_apply, normed_group_hom.coe_to_add_monoid_hom,
    add_equiv.coe_to_add_monoid_hom, add_equiv.coe_mk],
  dsimp only [Condensed.of_top_ab.presheaf, add_monoid_hom.mk'_apply],
  ext x,
  simp only [continuous_map.comp_apply],
  apply uniform_space.completion.induction_on t; clear t,
  { refine is_closed_eq _ _,
    { have h1 : continuous (λ q : C(X,V), q x) := continuous_map.continuous_eval_const.{u u} x,
      have h2 : continuous (uniform_space.completion.extension.{u u}
        locally_constant.to_continuous_map.{u u}) := uniform_space.completion.continuous_extension,
      have h3 := (locally_constant.comap_hom.{u u u} f f.continuous).completion.continuous,
      refine (h1.comp h2).comp h3,
      apply_instance },
    { let t := _, change continuous t,
      have ht : t = _ ∘ uniform_space.completion.extension
        (locally_constant.to_continuous_map.{u u}),
      rotate 2,
      { intros q, exact q (f x) },
      { refl },
      rw ht, clear ht t,
      apply continuous.comp,
      exact continuous_map.continuous_eval_const.{u u} (f x),
      exact uniform_space.completion.continuous_extension.{u u} } },
  { intros a,
    simp only [normed_group_hom.completion_coe,
      locally_constant.comap_hom_apply, quiver.hom.unop_op],
    erw [uniform_space.completion.extension_coe],
    erw [uniform_space.completion.extension_coe],
    unfold locally_constant.comap,
    classical,
    erw dif_pos, refl,
    exact f.continuous,
    exact locally_constant.to_continuous_map_uniform_continuous.{u} Y ↥V,
    exact locally_constant.to_continuous_map_uniform_continuous.{u} X ↥V },
end

def ExtQprime_iso_aux_system_obj_aux :
  ((CLC (SemiNormedGroup.ulift.{u+1}.obj V)).right_op.map_FreeAb ⋙
         FreeAb.eval SemiNormedGroupᵒᵖ) ⋙
    (forget₂ SemiNormedGroup Ab).op ≅
  (freeCond.map_FreeAb ⋙ FreeAb.eval (Condensed.{u} Ab.{u+1})) ⋙
    (preadditive_yoneda.obj V.to_Cond).right_op :=
begin
  refine nat_iso.of_components _ _,
  { intro X,
    dsimp only [functor.comp_obj, functor.right_op, functor.op_obj, FreeAb.eval,
      functor.map_FreeAb],
    refine iso.op _,
    refine (preadditive_yoneda_obj_obj_CondensedSet_to_Condensed_Ab _ _) ≪≫ _,
    let e := (Condensed_Ab_to_presheaf.map_iso (Condensed_LCC_iso_of_top_ab V)).app (op X.as),
    refine e.symm ≪≫ (ExtQprime_iso_aux_system_obj_aux' V X.as), },
  { intros X Y f,
    apply FreeAb_naturality_helper, clear f X Y, intros X Y f,
    dsimp only [id.def, iso.trans_hom, iso.op_hom, op_comp, iso.symm_hom, functor.map_iso_inv,
      functor.comp_map, functor.right_op_map, functor.op_map, iso.app_inv,
      FreeAb.eval, functor.map_FreeAb, FreeAb.of_functor],
    simp only [category.assoc, ← op_comp], congr' 1,
    simp only [free_abelian_group.map_of_apply, free_abelian_group.lift.of, id.def,
      functor.right_op_map, quiver.hom.unop_op],
    erw ← preadditive_yoneda_obj_obj_CondensedSet_to_Condensed_Ab_natural'_assoc,
    congr' 1,
    dsimp [Condensed_LCC_iso_of_top_ab],
    erw ExtQprime_iso_aux_system_obj_aux'_natural,
    simp only [← category.assoc], congr' 1,
    rw ← Ab.ulift.map_comp,
    rw ExtQprime_iso_aux_system_obj_aux_aux,
    ext, refl }
end

/-- Hom(X,A) -/
def hom_complex_int (X : homological_complex (Condensed.{u} Ab.{u+1})
  (complex_shape.up ℤ)) (A : Condensed.{u} Ab.{u+1}) :
  homological_complex Ab.{u+1} (complex_shape.up ℤ).symm :=
(((preadditive_yoneda.obj A).map_homological_complex _).obj X.op)

def hom_complex_nat (X : homological_complex (Condensed.{u} Ab.{u+1})
  (complex_shape.down ℕ)) (A : Condensed.{u} Ab.{u+1}) :
  homological_complex Ab.{u+1} (complex_shape.down ℕ).symm :=
(((preadditive_yoneda.obj A).map_homological_complex _).obj X.op)

def embed_hom_complex_nat_iso (X : homological_complex (Condensed.{u} Ab.{u+1})
  (complex_shape.down ℕ)) (A : Condensed.{u} Ab.{u+1}) :
  hom_complex_int ((homological_complex.embed
    complex_shape.embedding.nat_down_int_up).obj X) A ≅
  (homological_complex.embed complex_shape.embedding.nat_up_int_down).obj
  (hom_complex_nat X A) :=
homological_complex.hom.iso_of_components
(λ i,
match i with
| int.of_nat 0 := iso.refl _
| int.of_nat (i+1) := is_zero.iso (functor.map_is_zero _ (is_zero_zero _).op) (is_zero_zero _)
| -[1+i] := iso.refl _
end)
begin
  rintro i (j|(_|j)) (rfl : _ = _),
  { apply is_zero.eq_of_src,
    refine functor.map_is_zero _ _,
    dsimp, apply is_zero.op, exact is_zero_zero _ },
  { refine (category.id_comp _).trans (category.comp_id _).symm, },
  { refine (category.id_comp _).trans (category.comp_id _).symm, },
end

/-
lemma embed_hom_complex_nat_iso_homology_iso (X : homological_complex (Condensed.{u} Ab.{u+1})
  (complex_shape.down ℕ)) (A : Condensed.{u} Ab.{u+1}) (n : ℕ) :
  (homology_functor _ _ (-(n : ℤ))).map (embed_hom_complex_nat_iso X A).hom ≫
  (homological_complex.homology_embed_nat_iso _
    complex_shape.embedding.nat_up_int_down nat_up_int_down_c_iff
    n (-(n : ℤ)) (by { cases n; refl })).app _
  = _
-/

/-
-- OLD construction of ExtQprime_iso_aux_system_obj
begin
  refine (homology_functor _ _ (-n:ℤ)).map_iso _ ≪≫ _,
  { let C := ((preadditive_yoneda.obj V.to_Cond).right_op.map_homological_complex _).obj
      (((QprimeFP_nat r' BD κ M).obj c)),
    exact ((homological_complex.embed complex_shape.embedding.nat_up_int_down).obj C.unop), },
  { refine _ ≪≫ embed_unop.app (op (((preadditive_yoneda_obj V.to_Cond ⋙ forget₂ _ _).right_op.map_homological_complex
      (complex_shape.down ℕ)).obj ((QprimeFP_nat r' BD κ M).obj c))),
    dsimp,
    refine (homological_complex.unop_functor.right_op.map_iso _).unop,
    symmetry, refine (map_homological_complex_embed _).app _, },
  refine (homological_complex.homology_embed_nat_iso _
    complex_shape.embedding.nat_up_int_down nat_up_int_down_c_iff
    n (-n) (by { cases n; refl })).app _ ≪≫ (homology_functor _ _ _).map_iso _,
  refine hom_complex_QprimeFP_nat_iso_aux_system r' BD κ M V c
end
-/

def hom_complex_QprimeFP_nat_iso_aux_system (c : ℝ≥0) :
  hom_complex_nat.{u} ((QprimeFP_nat.{u} r' BD κ M).obj c) V.to_Cond ≅
  (aux_system.{u u+1} r' BD ⟨M⟩ (SemiNormedGroup.ulift.{u+1 u}.obj V) κ).to_Ab.obj (op.{1} c) :=
begin
  refine _ ≪≫ forget₂_unop.app _,
  let φ : op (((preadditive_yoneda.obj V.to_Cond).right_op.map_homological_complex (complex_shape.down ℕ)).obj
  ((QprimeFP_nat r' BD κ M).obj c)) ≅ _ := _,
  refine homological_complex.unop_functor.map_iso φ,
  refine ((category_theory.nat_iso.map_homological_complex
    (ExtQprime_iso_aux_system_obj_aux V) _).app ((breen_deligne.FPsystem r' BD _ κ).obj c)).op,
end

def ExtQprime_iso_aux_system_obj (c : ℝ≥0) (n : ℕ) :
  ((Ext n).obj (op $ (QprimeFP r' BD κ M).obj c)).obj ((single _ 0).obj V.to_Cond) ≅
  ((aux_system r' BD ⟨M⟩ (SemiNormedGroup.ulift.{u+1}.obj V) κ).to_AbH n).obj (op c) :=
Ext_compute_with_acyclic _ _ (ExtQprime_iso_aux_system_aux r' BD κ M V c) _ ≪≫
begin
  refine (homology_functor _ _ (-n:ℤ)).map_iso
    (embed_hom_complex_nat_iso _ _) ≪≫ _,
  refine (homological_complex.homology_embed_nat_iso _
    complex_shape.embedding.nat_up_int_down nat_up_int_down_c_iff
    n (-n) (by { cases n; refl })).app _ ≪≫ (homology_functor _ _ _).map_iso _,
  refine hom_complex_QprimeFP_nat_iso_aux_system r' BD κ M V c
end

attribute [reassoc] Ext_compute_with_acyclic_naturality

def cofan_point_iso_colimit {α : Type (u+1)}
  (X : α → bounded_homotopy_category (Condensed.{u} Ab.{u+1}))
  [bounded_homotopy_category.uniformly_bounded X] :
  (bounded_homotopy_category.cofan X).X ≅
  ∐ X :=
(bounded_homotopy_category.is_colimit_cofan X).cocone_point_unique_up_to_iso
  (colimit.is_colimit _)

variables (ι : ulift.{u+1} ℕ → ℝ≥0) (hι : monotone ι)

instance sigma_Qprime_int_bounded_above :
  ((homotopy_category.quotient (Condensed Ab) (complex_shape.up ℤ)).obj
    (∐ λ (k : ulift ℕ), (QprimeFP_int r' BD κ M).obj (ι k))).is_bounded_above :=
begin
  refine ⟨⟨1, _⟩⟩,
  intros a ha,
  refine is_zero.of_iso _ (homotopy_category.coproduct_iso _ _),
  apply category_theory.is_zero_colimit,
  intro,
  exact chain_complex.bounded_by_one _ _ ha,
end
.

def coproduct_shift (A : Type u)
  [category.{v} A]
  [abelian A]
  [has_coproducts A]
  (X : ulift.{v} ℕ → bounded_homotopy_category A)
  [uniformly_bounded X]
  (e : X ⟶ (λ i, X (ulift.up $ ulift.down i + 1))) :
  ∐ X ⟶ ∐ X :=
begin
  apply sigma.desc,
  intros i,
  refine _ ≫ sigma.ι _ (ulift.up $ ulift.down i + 1),
  refine e _,
end

@[reassoc]
lemma Ext_coproduct_iso_naturality_shift
  (A : Type u)
  [category.{v} A]
  [abelian A]
  [enough_projectives A]
  [has_coproducts A]
  [AB4 A]
  (X : ulift.{v} ℕ → bounded_homotopy_category A)
  [uniformly_bounded X]
  (e : X ⟶ (λ i, X (ulift.up $ ulift.down i + 1)))
  (i : ℤ) (Y) :
  ((Ext i).map (coproduct_shift _ X e).op).app Y ≫
  (Ext_coproduct_iso X _ _).hom =
  (Ext_coproduct_iso _ _ _).hom ≫
  pi.lift (λ j, pi.π _ (ulift.up (ulift.down j + 1)) ≫
    ((Ext i).map (e _).op).app Y) :=
begin
  dsimp only [Ext_coproduct_iso, Ext, Ext0, Ext_iso, functor.comp_map, whiskering_left,
    whisker_left, iso.trans_hom, functor.map_iso, preadditive_yoneda_coproduct_iso,
    functor.flip, pi_iso, as_iso, preadditive_yoneda_coproduct_to_product],
  simp only [category.assoc],
  simp only [quiver.hom.unop_op, iso.op_hom, replacement_iso_hom, iso.op_inv,
    replacement_iso_inv, iso.symm_mk],
  apply limit.hom_ext,
  intros j,
  simp only [category.assoc, limit.lift_π, fan.mk_π_app, limit.lift_π_assoc],
  simp only [← functor.map_comp, ← op_comp],
  congr' 2,
  simp only [category.assoc],
  apply lift_ext (∐ X).π, swap, apply_instance,
  dsimp [quiver.hom.unop_op],
  simp only [category.assoc, lift_lifts, lift_lifts_assoc],
  dsimp [uniform_π, coproduct_shift],
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc,
    lift_lifts_assoc],
end