import polytime.data_structures.list
import catalan

open_locale complexity_class
open_locale tree
open tencodable (encode)

inductive polytime' : ∀ {n : ℕ}, (vector (list bool) n → list bool) → Prop
| nil : @polytime' 0 (λ _, [])
| cons' (b : bool) : @polytime' 1 (λ v, b :: v.head)
| tail' : @polytime' 1 (λ v, v.head.tail)
| nth {n} (i : fin n) : polytime' (λ v, v.nth i)
| comp {m n f} (g : fin n → vector (list bool) m → list bool) :
    @polytime' n f → (∀ i, polytime' (g i)) → polytime' (λ a, f (vector.of_fn (λ i, g i a)))
| cases {n f g h} :
  @polytime' (n+1) f → @polytime' (n+1) g → @polytime' (n+1) h →
  @polytime' (n+1) (λ v, @list.cases_on _ (λ _, list bool) v.head (f v) (λ hd tl, if hd then g v else h v))
| fold {n f} : @polytime' (n+2) f →
  polysize_fun (λ v : vector (list bool) (n + 2), v.head.foldl (λ ls hd, f (ls ::ᵥ [hd] ::ᵥ v.tail.tail)) v.tail.head) →
  @polytime' (n+2) (λ v, v.head.foldl (λ ls hd, f ( ls ::ᵥ [hd]  ::ᵥ v.tail.tail)) v.tail.head)

namespace polytime'

theorem to_polytime {n f} (hf : @polytime' n f) : f ∈ₑ PTIME :=
begin
  induction hf,
  case polytime'.fold : n f hf hf' ih
  { apply polytime.list_foldl', rotate 3,
    { cases hf' with p hp, use p,
      rintro ⟨ls, v⟩, rcases v.exists_eq_cons with ⟨vhd, tl, rfl⟩, specialize hp (ls ::ᵥ tl),
      simp [function.has_uncurry.uncurry, polysize_vector_def] at hp ⊢,
      exact hp.trans (p.eval_mono $ add_le_add_left le_add_self _), },
    complexity, },
  complexity,
end

abbreviation polytime₁' (f : list bool → list bool) : Prop := @polytime' 1 (λ v, f v.head)
abbreviation polytime₂' (f : list bool → list bool → list bool) : Prop := @polytime' 2 (λ v, f v.head v.tail.head)

theorem of_eq {n} {f g : vector (list bool) n → list bool} (hf : polytime' f) (H : ∀ n, f n = g n) : polytime' g :=
(funext H : f = g) ▸ hf

def wrap1 {f} (hf : @polytime' 1 f) : polytime₁' (λ x, f (x ::ᵥ vector.nil)) :=
hf.of_eq $ λ v, by simp [vector.one_eq_head]

lemma nil' {n : ℕ} : @polytime' n (λ v, []) :=
polytime'.comp fin.elim0 polytime'.nil fin.elim0

lemma cons {n f} (hf : @polytime' n f) (b : bool) : polytime' (λ v, b :: f v) :=
polytime'.comp (λ _, f) (polytime'.cons' b) (λ _, hf)

lemma polytime'_cons₂ : polytime₂' (λ a b, a.head :: b) :=
(polytime'.cases ((polytime'.nth 1).cons default) ((polytime'.nth 1).cons tt) ((polytime'.nth 1).cons ff)).of_eq $ λ n,
by rcases n.head with (_|⟨(_|_), tl⟩); simp [vector.nth_one_eq_tail_head]

lemma cons₂ {n f g} (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, (f v).head :: g v) := polytime'.comp ![f, g] polytime'_cons₂ (λ i, by fin_cases i; simpa)

lemma tail {n f} (hf : @polytime' n f) : polytime' (λ v, (f v).tail) :=
polytime'.comp (λ _, f) polytime'.tail' (λ _, hf)

lemma vtail {n f} (hf : @polytime' n f) : @polytime' (n + 1) (λ v, f v.tail) :=
(polytime'.comp (λ (i : fin n) v, v.nth i.succ) hf (λ i, by simpa using polytime'.nth _)).of_eq (λ v, by { congr, ext i : 1, simp, })

theorem foldl' {n ls f acc} (hls : @polytime' n ls) (hf : @polytime' (n + 2) f)
  (hacc : @polytime' n acc)
  (hr : polysize_fun (λ v : vector (list bool) (n + 2), v.head.foldl (λ acc' hd, f (acc' ::ᵥ [hd] ::ᵥ v.tail.tail)) v.tail.head)) :
  polytime' (λ v, (ls v).foldl (λ acc' hd, f (acc' ::ᵥ [hd] ::ᵥ v)) (acc v)) :=
(polytime'.comp (fin.cons ls (fin.cons acc (λ i v, v.nth i))) (polytime'.fold hf hr) (begin
  refine fin.cases _ _, { simpa, },
  refine fin.cases _ _, { simpa, },
  simpa using polytime'.nth,
end)).of_eq $ λ v, by simp

protected theorem foldl {n ls f acc} (hls : @polytime' n ls) (hf : @polytime' (n + 2) f)
  (hacc : @polytime' n acc)
  (hr : polysize_safe (λ (usf : vector (list bool) n × bool) (sf : list bool), f (sf ::ᵥ [usf.2] ::ᵥ usf.1))) :
  polytime' (λ v, (ls v).foldl (λ acc' hd, f (acc' ::ᵥ [hd] ::ᵥ v)) (acc v)) :=
foldl' hls hf hacc begin
  apply polysize_safe.foldl, rotate 2,
  { cases hr with pr hr, use pr, rintro ⟨x, hd⟩ acc, specialize hr (x.tail.tail, hd) acc,
    simp at hr ⊢, exact hr.trans (add_le_add_left (pr.eval_mono $ x.tail.polysize_tail_le_self.trans x.polysize_tail_le_self) _), },
  complexity,
end

theorem polytime'_reverse : @polytime' 1 (λ v, v.head.reverse) :=
((polytime'.nth 0).foldl ((polytime'.nth 1).cons₂ (polytime'.nth 0)) polytime'.nil'
(by { simp, complexity, })).of_eq $ λ v, by { simp, rw [← list.foldr_reverse, list.foldr_eta], }

theorem reverse {n f} (hf : @polytime' n f) : polytime' (λ v, (f v).reverse) :=
polytime'.comp (λ _ : fin 1, f) polytime'_reverse (λ _, hf)

theorem polytime'_append : @polytime' 2 (λ v, v.head ++ v.tail.head) :=
((polytime'.nth 0).reverse.foldl ((polytime'.nth 1).cons₂ (polytime'.nth 0)) (polytime'.nth 1)
(by { simp, complexity, })).of_eq $ λ v, by { simp [vector.nth_one_eq_tail_head], induction v.head; simp [*], }

theorem append {n f g} (hf : @polytime' n f) (hg : @polytime' n g) : polytime' (λ v, (f v) ++ (g v)) :=
polytime'.comp ![f, g] polytime'_append (λ i, by fin_cases i; simpa)

theorem ite₃ {n c f g h} (hc : @polytime' n c) (hf : @polytime' n f) (hg : @polytime' n g)
  (hh : @polytime' n h) : polytime' (λ v, @list.cases_on _ (λ _, list bool) (c v) (f v) (λ hd _, if hd then g v else h v)) :=
(@polytime'.comp n (n + 1) _ (fin.cons c (λ i v, v.nth i))
  (polytime'.cases hf.vtail hg.vtail hh.vtail)
  (by { refine fin.cases _ _, simpa, simpa using polytime'.nth, })).of_eq $ λ v,
by { simp, congr, simp, }

theorem ite_nil {n c f g} (hc : @polytime' n c) (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, if (c v).empty then f v else g v) :=
(hc.ite₃ hf hg hg).of_eq (λ v, by cases (c v); simp)

protected theorem ite {n c f g} (hc : @polytime' n c) (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, if (c v).head then f v else g v) :=
(hc.ite₃ hg hf hg).of_eq $ λ v, by { rcases (c v) with (_|⟨hd, tl⟩); simp, }

theorem ite_head {n c f g} (hc : @polytime' n c) (b : bool) (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, if (c v).head = b then f v else g v) :=
by { cases b, { refine (hc.ite hg hf).of_eq (λ v, _), cases (c v).head; simp, }, refine (hc.ite hf hg).of_eq (λ v, _), cases (c v).head; simp, }

theorem ite_len_eq {n c f g} (hc : @polytime' n c) (l : ℕ) (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, if (c v).length = l then f v else g v) :=
begin
  induction l with l ih generalizing c, { refine (hc.ite_nil hf hg).of_eq _, simp [list.empty_iff_eq_nil, list.length_eq_zero], },
  refine (hc.ite_nil hg $ ih hc.tail).of_eq (λ v, _),
  cases c v; simp [nat.succ_eq_add_one, @eq_comm ℕ 0],
end

theorem ite_eq {n c f g} (hc : @polytime' n c) (x : list bool) (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, if c v = x then f v else g v) :=
begin
  induction x with hd tl ih generalizing c, { refine (hc.ite_nil hf hg).of_eq _, simp [list.empty_iff_eq_nil], },
  refine (hc.ite_nil hg $ hc.ite_head hd (ih hc.tail) hg).of_eq (λ v, _),
  cases c v, { simp, }, { simp [ite_and], }
end

lemma polytime'_sum_parens : polytime₁' (λ x, list.repeat tt $ sum_parens (x.map paren.to_bool.symm)) :=
((polytime'.nth 0).foldl
   ((polytime'.nth 0).ite_nil polytime'.nil' -- if acc = 0
      ((polytime'.nth 1).ite_head paren.up.to_bool -- if hd = paren.up
         ((polytime'.nth 0).cons tt) -- acc + 1
         ((polytime'.nth 0).tail))) -- acc - 1
   (polytime'.nil'.cons tt) -- [tt]
   (by { simp, complexity, })
  ).of_eq $ λ v, begin
  simp only [vector.nth_zero],
  induction v.head using list.reverse_rec_on with xs x ih, { simp [sum_parens], },
  rw [list.foldl_append, ih],
  simp [list.empty_iff_eq_nil, ← list.length_eq_zero, apply_ite (list.repeat tt), paren.to_bool.symm_apply_eq],
  refl,
end

lemma sum_parens {n f} (hf : @polytime' n f) : polytime' (λ v, list.repeat tt $ sum_parens ((f v).map paren.to_bool.symm)) :=
polytime'.comp (λ _ : fin 1, f) polytime'_sum_parens (λ _, hf)

lemma is_balanced {n f} (hf : @polytime' n f) : polytime' (λ v, [paren.are_heights_nonneg ((f v).map paren.to_bool.symm)]) :=
(hf.sum_parens.ite_len_eq 1 (polytime'.nil'.cons tt) (polytime'.nil'.cons ff)).of_eq $ λ v, begin
  by_cases H : paren.are_heights_nonneg ((f v).map paren.to_bool.symm); simp [is_balanced_iff, H],
end

lemma init {n f} (hf : @polytime' n f) : polytime' (λ v, (f v).init) :=
hf.reverse.tail.reverse.of_eq $ λ v, by induction f v using list.reverse_rec_on; simp

lemma polytime'_left : polytime₁' (λ x, (left_dyck_word $ x.map paren.to_bool.symm).map paren.to_bool) :=
((polytime'.nth 0).ite_nil polytime'.nil' $
  ((polytime'.nth 0).foldl (
    (polytime'.nth 0).ite_nil ((polytime'.nth 0).append $ polytime'.nth 1) $
    (polytime'.nth 0).is_balanced.ite (polytime'.nth 0) ((polytime'.nth 0).append $ polytime'.nth 1)
  ) polytime'.nil' (by { simp, complexity, })).tail.init).of_eq $ λ v, begin
  simp only [vector.nth_zero, list.empty_iff_eq_nil, left_dyck_word, list.map_eq_nil],
  split_ifs, { simp [left_dyck_word], },
  simp only [list.map_tail, list.map_init], congr,
  change _ = equiv_functor.map_equiv list paren.to_bool _, rw list.foldl_transport_equiv,
  simp [left_alg_foldl, list.empty_iff_eq_nil, equiv_functor.map, apply_ite (list.map paren.to_bool), ite_and],
end

lemma left {n f} (hf : @polytime' n f) : polytime' (λ v, (left_dyck_word $ (f v).map paren.to_bool.symm).map paren.to_bool) :=
polytime'.comp (λ _, f) polytime'_left (λ _, hf)

lemma polytime'_drop : @polytime' 2 (λ v, v.head.drop v.tail.head.length) :=
((polytime'.nth 1).foldl (polytime'.nth 0).tail (polytime'.nth 0) (by { simp, complexity, })).of_eq
  (λ v, by simp [vector.nth_one_eq_tail_head])

lemma drop {n f g} (hf : @polytime' n f) (hg : @polytime' n g) :  polytime' (λ v, (f v).drop (g v).length) :=
polytime'.comp ![f, g] polytime'_drop $ λ i, by fin_cases i; simpa

lemma polytime'_right : polytime₁' (λ x, (right_dyck_word $ x.map paren.to_bool.symm).map paren.to_bool) :=
((polytime'.nth 0).drop (polytime'.nth 0).left).tail.tail.of_eq $ λ v, by { simp [right_dyck_word, list.map_drop, list.tail_drop], }

lemma right {n f} (hf : @polytime' n f) : polytime' (λ v, (right_dyck_word $ (f v).map paren.to_bool.symm).map paren.to_bool) :=
polytime'.comp (λ _, f) polytime'_right (λ _, hf)

lemma polytime'_count_tt : polytime₁' (λ x, list.repeat tt (x.count tt)) :=
((polytime'.nth 0).foldl ((polytime'.nth 1).ite ((polytime'.nth 0).cons tt) (polytime'.nth 0)) polytime'.nil'
  (by { simp, complexity, })).of_eq $ λ v,
by { simp, induction v.head using list.reverse_rec_on with l e ih, { simp, }, cases e; simp [*], }

lemma count_tt {n f} (hf : @polytime' n f) : polytime' (λ v, list.repeat tt $ (f v).count tt) :=
polytime'.comp (λ _, f) polytime'_count_tt (λ _, hf)

lemma iter {n f k s} (hf : polytime₁' f) (hk : @polytime' n k) (hs : @polytime' n s)
  (hf' : polysize_fun (λ (n : ℕ) (s : list bool), f^[n] s)) :
  polytime' (λ v, f^[(k v).length] (s v)) :=
(hk.foldl' (polytime'.comp _ hf (λ _, polytime'.nth 0)) hs begin
  simp only [vector.nth_cons_zero, vector.head_of_fn, list.foldl_eq_iterate],
  cases hf' with p hp, use p,
  rintro ⟨(_|⟨a, (_|⟨b, x⟩)⟩), hx⟩, iterate 2 { exfalso, refine absurd hx _, dec_trivial, },
  simp only [vector.head, vector.tail, polysize_vector_def, list.map, tree.polytime.uncurry_unary, size_list_fintype,
    vector.to_list_map, vector.to_list_mk, list.sum_cons, ← add_assoc],
  refine trans _ (p.eval_mono le_self_add),
  simpa [function.has_uncurry.uncurry] using hp (a.length, b),
end).of_eq $ λ v, by simp

-- We extract the inductive case of the iter step because it is large
lemma of_tree_polytime_iter_case (f : tree unit → tree unit) (hf : polysize_fun (λ x : tree unit, f^[x.left.num_nodes] x.right))
  (f' : list bool → list bool) (h₁ : polytime₁' f') (h₂ : ∀ (x : paren.dyck_words),
    f' (list.map paren.to_bool ↑x) = list.map paren.to_bool ↑(tree.equiv_dyck_words (f (tree.equiv_dyck_words.symm x)))) :
  ∃ (g : list bool → list bool), polytime₁' g ∧ ∀ (x : paren.dyck_words),
    g (list.map paren.to_bool ↑x) = list.map paren.to_bool ↑(tree.equiv_dyck_words (
      (λ x : tree unit, f^[x.left.num_nodes] x.right) (tree.equiv_dyck_words.symm x))) :=
begin
  set F : list bool → list bool := λ b, if paren.are_heights_nonneg (b.map paren.to_bool.symm) then f' b else [],
  have hF : ∀ (x : list bool) (n : ℕ), paren.are_heights_nonneg (x.map paren.to_bool.symm) → (F^[n] x) = (f'^[n] x),
  { rintros x n h,
    induction n with n ih generalizing x, { refl, },
    have : F x = f' x, { dsimp [F], simp [h], },
    rw [function.iterate_succ_apply, ih], { simp [this], },
    specialize h₂ ⟨_, h⟩, simp only [paren.coe_mk, list.map_map, equiv.self_comp_symm, list.map_id] at h₂,
    simp [this, h₂], exact subtype.prop _, },
  have hF' : ∀ (x : list bool), ¬paren.are_heights_nonneg (x.map paren.to_bool.symm) → F x = [], { intros x H, dsimp [F], simp [H], },
  have hf' : ∀ (x : paren.dyck_words) (n : ℕ), (f'^[n] $ (↑x : list paren).map paren.to_bool) =
    list.map paren.to_bool ↑(tree.equiv_dyck_words (f^[n] (tree.equiv_dyck_words.symm x))),
  { intros x n, induction n with n ih generalizing x, { simp, }, simp [ih, h₂], },
  have pF : polytime₁' F := ((polytime'.nth 0).is_balanced.ite h₁ polytime'.nil').of_eq (by simp),
  refine ⟨_, (iter pF (polytime'.nth 0).left.count_tt (polytime'.nth 0).right _).wrap1, _⟩,
  { cases hf with pf hf,
    have : ∀ (n : ℕ) (b : list bool), paren.are_heights_nonneg (b.map paren.to_bool.symm) →
      (f'^[n] b).length ≤ 2 * pf.eval (n + b.length + 1),
    { intros n b hb,
      suffices : (f'^[n] b).length ≤ 2 * pf.eval (n + b.length / 2 + 1), { refine this.trans _, mono*, exacts [nat.div_le_self _ _, zero_le'], },
      specialize hf' ⟨_, hb⟩ n, specialize hf ((encode n) △ tree.equiv_dyck_words.symm ⟨_, hb⟩),
      simp [tree.equiv_dyck_words_symm_num_nodes] at hf' hf,
      simpa [hf', tree.equiv_dyck_words_length] using hf, },
    use 2 * pf.comp (polynomial.X + 1), rintro ⟨n, b⟩,
    dsimp [function.has_uncurry.uncurry] at ⊢ hf,
    by_cases H : paren.are_heights_nonneg (b.map paren.to_bool.symm),
    { rw hF _ n H, simpa using this n _ H, },
    cases n,
    { have : b.length ≤ pf.eval (b.length + 1) := by simpa using (hf (tree.nil △ (encode b.length))),
      simp, linarith only [this], },
    rw [function.iterate_succ_apply, hF' _ H, hF [] n dec_trivial],
    specialize this n [] dec_trivial,
    simp, refine this.trans _, mono*, exacts [nat.le_succ _, zero_le', zero_le'], },
  intro x,
  simp only [vector.nth_cons_nil, list.map_map, equiv.symm_comp_self, list.count_map_of_equiv,
    list.map_id, left_dyck_word_spec, list.length_repeat, right_dyck_word_spec, tree.equiv_dyck_words_num_nodes_eq_count],
  rw [hF, hf'], { simp, }, simpa using x.right.prop,
end

lemma pair {n f g} (hf : @polytime' n f) (hg : @polytime' n g) :
  polytime' (λ v, paren.up.to_bool :: (f v) ++ paren.down.to_bool :: (g v)) :=
(hf.cons paren.up.to_bool).append (hg.cons paren.down.to_bool)

lemma of_tree_polytime {f : tree unit → tree unit} (hf : tree.polytime f) :
  ∃ f' : list bool → list bool, polytime₁' f' ∧ ∀ (x : paren.dyck_words),
    f' ((↑x : list paren).map paren.to_bool) = (↑(tree.equiv_dyck_words $ f (tree.equiv_dyck_words.symm x)) : list paren).map paren.to_bool :=
begin
  induction hf,
  case tree.polytime.nil { { refine ⟨λ _, [], polytime'.nil', _⟩, simp, } },
  case tree.polytime.id' { { refine ⟨λ x, x, (polytime'.nth 0).of_eq _, _⟩; simp, } },
  case tree.polytime.left { { refine ⟨_, polytime'_left, _⟩, simp, } },
  case tree.polytime.right { { refine ⟨_, polytime'_right, _⟩, simp, } },
  case tree.polytime.pair : f g _ _ ihf ihg
  { { rcases ihf with ⟨f', ihf, Hf⟩, rcases ihg with ⟨g', ihg, Hg⟩,
    refine ⟨_, (ihf.pair ihg).wrap1, _⟩,
    simp [Hf, Hg], } },
  case tree.polytime.comp : f g _ _ ihf ihg
  { { rcases ihf with ⟨f', ihf, Hf⟩, rcases ihg with ⟨g', ihg, Hg⟩,
    refine ⟨λ x, f' (g' x), polytime'.comp (λ _ v, g' v.head) ihf (λ _, ihg), _⟩,
    simp [Hf, Hg], } },
  case tree.polytime.ite : f g h _ _ _ ihf ihg ihh
  { { rcases ihf with ⟨f', ihf, Hf⟩, rcases ihg with ⟨g', ihg, Hg⟩, rcases ihh with ⟨h', ihh, Hh⟩,
    refine ⟨λ x, if (f' x).empty then g' x else h' x, ihf.ite_nil ihg ihh, _⟩,
    intro x, simp only [Hf],
    rcases f (tree.equiv_dyck_words.symm x) with (_|⟨⟨⟩, _, _⟩); simp [Hg, Hh], } },
  case tree.polytime.bounded_rec : f _ hf ih { rcases ih with ⟨f', h₁, h₂⟩, exact of_tree_polytime_iter_case f hf f' h₁ h₂, },
end

protected lemma const : ∀ (b : list bool), @polytime' 0 (λ _, b)
| [] := polytime'.nil
| (b :: xs) := (const xs).cons b

lemma const' {n : ℕ} (b : list bool) : @polytime' n (λ _, b) :=
polytime'.comp fin.elim0 (polytime'.const b) fin.elim0

lemma encode_bool {n f} (hf : @polytime' n f) : polytime' (λ v, list.map paren.to_bool ↑(tree.equiv_dyck_words (encode (f v).head))) :=
(hf.ite (const' $ list.map paren.to_bool ↑(tree.equiv_dyck_words (encode tt)))
  (const' $ list.map paren.to_bool ↑(tree.equiv_dyck_words (encode ff)))).of_eq $ λ v, by cases (f v).head; simp

instance : tencodable paren := tencodable.of_equiv bool paren.to_bool

lemma encode_list_aux : polytime₁' (λ b : list bool, list.map paren.to_bool ↑(tree.equiv_dyck_words (encode b))) :=
((polytime'.nth 0).reverse.foldl ((polytime'.nth 1).encode_bool.pair (polytime'.nth 0))
  nil' (begin
    simp, refine polysize_safe.cons _ (polysize_safe.append_left (polytime.size_le _) _), swap,
    { rw [complexity_class.mem₂_iff, complexity_class.mem.swap_args₂, complexity_class.iff_fintype],
      intro x, simpa [flip] using polytime.const _, },
    complexity,
  end)).of_eq $ λ v, begin
  simp only [list.head, list.map, vector.cons_cons_nth_one, vector.cons_head,
    vector.nth_cons_zero, list.cons_append, vector.nth_zero, list.foldl_reverse],
  induction v.head with hd tl ih, { simp [tencodable.encode_nil], },
  simp [ih, tencodable.encode_cons],
end

lemma encode_list {n f} (hf : @polytime' n f) : polytime' (λ v, list.map paren.to_bool ↑(tree.equiv_dyck_words (encode (f v)))) :=
polytime'.comp (λ _, f) encode_list_aux (λ _, hf)

lemma encode_vec : ∀ (n : ℕ), @polytime' n (λ v, list.map paren.to_bool ↑(tree.equiv_dyck_words (encode v)))
| 0 := (polytime'.const []).of_eq (λ v, by rw v.eq_nil; refl)
| (n + 1) := ((polytime'.nth 0).encode_list.pair (encode_vec n).vtail).of_eq
  (λ v, by { conv_rhs { rw [← v.cons_head_tail, tencodable.encode_vec_cons], }, simp, })

lemma of_polytime_aux {n : ℕ} {α : Type} [tencodable α] {f : vector (list bool) n → α} :
  f ∈ₑ PTIME → polytime' (λ v, list.map paren.to_bool ↑(tree.equiv_dyck_words (encode $ f v)))
| ⟨f', pf, hf⟩ := let ⟨g, pg, hg⟩ := of_tree_polytime pf in by simpa [hg, hf] using polytime'.comp _ pg (λ _, encode_vec n)

lemma of_nth {n : ℕ} {f : vector (list bool) n → list bool}
  (h₁ : @polytime' (n + 1) (λ v, ((f v.tail).nth v.head.length).to_list))
  (h₂ : polysize_fun f) : polytime' f :=
begin
  cases h₂ with p hp, simp [polysize.size] at hp,
  obtain ⟨B, pB, hB⟩ : ∃ B : vector (list bool) n → list bool, polytime' B ∧
    ∀ v, (f v).length ≤ (B v).length,
  { refine ⟨_, of_polytime_aux (show (λ v : vector (list bool) n,
      p.eval (v.to_list.map list.length).sum) ∈ₑ PTIME, by complexity), λ v, (hp v).trans _⟩,
    simpa [tree.equiv_dyck_words_length] using nat.le_mul_of_pos_left (nat.zero_lt_succ _ : 0 < 2), },
  replace h₁ : polytime' (λ (v : vector (list bool) (n + 2)), ((f v.tail.tail).nth v.head.length).to_list),
  { refine (@polytime'.comp (n + 2) (n + 1) _ (by { refine fin.cases _ _, exacts [vector.head, λ n v, v.nth n.succ.succ], }) h₁ _).of_eq (λ v, _),
    { refine fin.cases _ _, { simpa using @polytime'.nth (n + 2) 0, }, { intro i, simpa using polytime'.nth _, }, },
    simp, congr, ext i : 1, simp, },
  refine (pB.foldl ((polytime'.nth 0).append h₁) polytime'.nil' _).of_eq (λ v, _),
  { simp, use 1, intros x y, simpa using option.to_list_length_le_one _, }, { simp [list.iterate_append_nth_eq_self, list.take_all_of_le (hB v)], },
end

lemma to_list {n : ℕ} {f : vector (list bool) n → option bool} (hf : f ∈ₑ PTIME) :
  polytime' (λ v, (f v).to_list) :=
((of_polytime_aux hf).ite_eq (list.map paren.to_bool ↑(tree.equiv_dyck_words (encode (none : option bool))))
  polytime'.nil' $
  (of_polytime_aux hf).ite_eq (list.map paren.to_bool ↑(tree.equiv_dyck_words (encode (some ff))))
  (polytime'.const' [ff]) (polytime'.const' [tt])).of_eq $ λ v, by rcases f v with (_|_|_); refl

@[complexity] lemma of_polytime {n : ℕ} {f : vector (list bool) n → list bool} (hf : f ∈ₑ PTIME) : polytime' f :=
of_nth (to_list $ by complexity) (polytime.size_le hf)

lemma iff_polytime {n : ℕ} {f : vector (list bool) n → list bool} :
  polytime' f ↔ f ∈ₑ PTIME := ⟨to_polytime, of_polytime⟩

lemma _root_.polytime.equiv_dyck_words : (λ x : tree unit, (↑(tree.equiv_dyck_words x) : list paren)) ∈ₑ PTIME :=
begin
  complexity using λ x, x.stack_rec (λ _ : unit, []) (λ _ _ _, ()) (λ _ _ _, ())
    (λ ih₁ ih₂ _ _ _, paren.up :: (ih₁ ++ paren.down :: ih₂)) (),
  { use 1, simp [add_assoc], },
  induction x using tree.unit_rec_on; simp [*],
end

end polytime'


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.finite
import morphisms.finite_type
import for_mathlib.integral
import morphisms.universally_closed
import ring_theory.ring_hom.integral
import for_mathlib.algebra_is_pushout

/-!

# Integral morphisms

A morphism of schemes is integral if it is affine and the component of the sheaf map on integral opens
is integral.
We show that this property is local, and is stable under compositions and base-changes.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

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

/--
A morphism is `integral` if the preimages of integral open sets are integral.
-/
@[mk_iff]
class integral (f : X ⟶ Y) extends affine f : Prop :=
(is_integral_of_affine [] :
  ∀ U : opens Y.carrier, is_affine_open U → (f.1.c.app (op U)).is_integral)

def integral.affine_property : affine_target_morphism_property :=
affine_and (λ R S _ _ f, by exactI ring_hom.is_integral f)

lemma integral_eq_affine_property :
  @integral = target_affine_locally integral.affine_property :=
by { ext, rw [integral_iff, integral.affine_property,
  affine_and_target_affine_locally_iff ring_hom.is_integral_respects_iso] }

lemma integral.affine_property_is_local :
  integral.affine_property.is_local :=
is_local_affine_and _ ring_hom.is_integral_respects_iso ring_hom.localization_is_integral
  ring_hom.is_integral_of_localization_span

lemma integral_is_local_at_target :
  property_is_local_at_target @integral :=
integral_eq_affine_property.symm ▸ integral.affine_property_is_local.target_affine_locally_is_local

lemma integral_respects_iso : morphism_property.respects_iso @integral :=
integral_is_local_at_target.respects_iso

lemma integral_stable_under_composition : morphism_property.stable_under_composition @integral :=
by { rw integral_eq_affine_property, exact affine_and_stable_under_composition _
  ring_hom.is_integral_stable_under_composition }

lemma integral_stable_under_base_change : morphism_property.stable_under_base_change @integral :=
by { rw integral_eq_affine_property, exact affine_and_stable_under_base_change _
  ring_hom.is_integral_respects_iso ring_hom.localization_is_integral
  ring_hom.is_integral_of_localization_span
  ring_hom.is_integral_stable_under_base_change }

lemma integral_le_affine :
  @integral ≤ @affine :=
by { rw integral_eq_affine_property, exact target_affine_locally_affine_and_le_affine _ }

lemma integral_Spec_iff {R S : CommRing} (f : R ⟶ S) :
  integral (Scheme.Spec.map f.op) ↔ ring_hom.is_integral f :=
begin
  rw [integral_eq_affine_property,
    integral.affine_property_is_local.affine_target_iff,
    integral.affine_property, affine_and_Spec_iff ring_hom.is_integral_respects_iso]
end

lemma finite_eq_integral_inf_locally_of_finite_type :
  @finite = @integral ⊓ @locally_of_finite_type :=
begin
  apply property_ext_of_le_affine finite_le_affine
    (inf_le_left.trans integral_le_affine) finite_is_local_at_target
    (integral_is_local_at_target.inf locally_of_finite_type_is_local_at_target),
  intros R S f,
  simp_rw [pi.inf_apply, finite_Spec_iff, integral_Spec_iff, locally_of_finite_type_Spec_iff],
  exact ⟨λ h, ⟨h.to_is_integral, h.to_finite_type⟩,
    λ h, ring_hom.finite.of_is_integral_of_finite_type h.1 h.2⟩
end

instance finite.to_integral [hf : finite f] : integral f :=
by { rw finite_eq_integral_inf_locally_of_finite_type at hf, exact hf.1 }

instance finite.to_locally_of_finite_type [hf : finite f] : locally_of_finite_type f :=
by { rw finite_eq_integral_inf_locally_of_finite_type at hf, exact hf.2 }

-- lemma integral.affine_open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
--   tfae [integral f,
--     ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)],
--       ∀ (i : 𝒰.J), is_affine (pullback f (𝒰.map i)) ∧
--         ring_hom.integral (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op),
--     ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
--       is_affine (pullback f (𝒰.map i)) ∧
--         ring_hom.integral (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op),
--     ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
--       is_affine (pullback f g) ∧
--         ring_hom.integral (Scheme.Γ.map (pullback.snd : pullback f g ⟶ _).op)] :=
-- integral_eq_affine_property.symm ▸
--   integral.affine_property_is_local.affine_open_cover_tfae f

-- lemma integral.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
--   tfae [integral f,
--     ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
--       integral (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
--     ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
--       integral (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
--     ∀ (U : opens Y.carrier), integral (f ∣_ U),
--     ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
--       integral (pullback.snd : pullback f g ⟶ _)] :=
-- affine_eq_affine_property.symm ▸
--   affine_affine_property_is_local.open_cover_tfae f

lemma integral_over_affine_iff [is_affine Y] :
  integral f ↔ is_affine X ∧ ring_hom.is_integral (Scheme.Γ.map f.op) :=
integral_eq_affine_property.symm ▸
  integral.affine_property_is_local.affine_target_iff f

lemma integral.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  integral f ↔ ∀ i, is_affine (pullback f (𝒰.map i)) ∧
    ring_hom.is_integral (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op) :=
integral_eq_affine_property.symm ▸
  integral.affine_property_is_local.affine_open_cover_iff f 𝒰

lemma integral.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  integral f ↔ ∀ i, integral (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
integral_eq_affine_property.symm ▸
  integral.affine_property_is_local.target_affine_locally_is_local.open_cover_iff f 𝒰

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [integral g] :
  integral (pullback.fst : pullback f g ⟶ X) :=
integral_stable_under_base_change (is_pullback.of_has_pullback f g).flip infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [integral f] :
  integral (pullback.snd : pullback f g ⟶ Y) :=
integral_stable_under_base_change (is_pullback.of_has_pullback f g) infer_instance

lemma topologically_is_closed_map_respects_iso :
  (morphism_property.topologically @is_closed_map).respects_iso :=
begin
  apply morphism_property.stable_under_composition.respects_iso,
  { intros X Y Z f g hf hg, exact hg.comp hf },
  { intros X Y e, exact (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso e).is_closed_map },
end

lemma is_closed_map_of_is_integral_of_is_affine [integral f] [is_affine Y] :
  is_closed_map f.1.base :=
begin
  haveI := is_affine_of_affine f,
  apply (topologically_is_closed_map_respects_iso.arrow_mk_iso_iff
    (Spec_Γ_arrow_iso_of_is_affine f)).mpr,
  apply prime_spectrum.is_closed_map_of_is_integral,
  exact (integral.is_integral_of_affine f _ (top_is_affine_open _) : _),
end

@[priority 100]
instance integral.to_universally_closed [hf : integral f] : universally_closed f :=
begin
  constructor,
  rintros X' Y' i₁ i₂ f' H,
  replace hf := integral_stable_under_base_change H.flip hf,
  clear_dependent X Y,
  apply (is_closed_map_iff_is_closed_map_of_supr_eq_top Y'.affine_cover.supr_opens_range).mpr,
  introI i,
  rw [← morphism_restrict_val_base],
  haveI := integral_is_local_at_target.2 f' (Y'.affine_cover.map i).opens_range infer_instance,
  haveI : is_affine _ := range_is_affine_open_of_open_immersion (Y'.affine_cover.map i),
  apply is_closed_map_of_is_integral_of_is_affine
end

open_locale polynomial
local attribute [instance] polynomial.polynomial_algebra_of_algebra

open_locale big_operators

lemma polynomial.reflect_map {R S : Type*} [comm_ring R] [comm_ring S] (p : R[X]) (f : R →+* S) (n : ℕ) :
  (p.map f).reflect n = (p.reflect n).map f :=
begin
  ext i, simp,
end

lemma _root_.ring_hom.is_integral_elem_of_is_nilpotent {R S : Type*} [comm_ring R] [comm_ring S]
  (f : R →+* S) {x : S}
  (hx : is_nilpotent x) : f.is_integral_elem x :=
begin
  cases hx with n hx,
  refine ⟨polynomial.monomial n (1 : R), polynomial.leading_coeff_monomial _ _, _⟩,
  rw [polynomial.eval₂_monomial, hx, mul_zero]
end

lemma integral_eq_affine_inf_universally_closed :
  @integral = @affine ⊓ @universally_closed :=
begin
  apply le_antisymm,
  { introsI X Y f hf, exact ⟨infer_instance, infer_instance⟩ },
  { apply property_le_of_le_affine inf_le_left
      (affine_is_local_at_target.inf universally_closed_is_local_at_target)
      integral_is_local_at_target,
    simp_rw [pi.inf_apply, integral_Spec_iff],
    rintros R S f ⟨-, h₂⟩ a,
    by_cases ha : is_nilpotent a, { exact ring_hom.is_integral_elem_of_is_nilpotent _ ha },
    let p : S[X] := polynomial.monomial 1 a - polynomial.C 1,
    letI := f.to_algebra,
    haveI : universally_closed (Scheme.Spec.map (CommRing.of_hom (algebra_map R S)).op),
    { convert h₂; exact CommRing.of_eq _ },
    have := universally_closed.out _ _ _
      ((algebra.is_pushout.to_is_pushout R S R[X] S[X]).op.map Scheme.Spec) _
      (prime_spectrum.is_closed_zero_locus $ {p}),
    change is_closed (prime_spectrum.comap (algebra_map R[X] S[X]) ''
      prime_spectrum.zero_locus {p}) at this,
    rw [← prime_spectrum.zero_locus_span, ← closure_eq_iff_is_closed,
      prime_spectrum.closure_image_comap_zero_locus, prime_spectrum.zero_locus_span] at this,
    have : (1 : R[X]) ∈ ideal.span {polynomial.X} ⊔ (ideal.span {p}).comap (algebra_map R[X] S[X]),
    { rw [← ideal.eq_top_iff_one, sup_comm, ← prime_spectrum.zero_locus_empty_iff_eq_top,
      prime_spectrum.zero_locus_sup, this, prime_spectrum.zero_locus_span,
      set.eq_empty_iff_forall_not_mem],
      rintros _ ⟨⟨x, hx : _ ⊆ _, rfl⟩, hx' : _ ⊆ _⟩,
      apply x.2.1,
      replace hx' : polynomial.X ∈ x.as_ideal,
      { rw set.singleton_subset_iff at hx', change _ ∈ x.as_ideal at hx',
        rwa [polynomial.polynomial_algebra_of_algebra_algebra_map_apply, polynomial.map_X] at hx' },
      rw set.singleton_subset_iff at hx,
      have : _ - (_ - _) ∈ _ := sub_mem (x.as_ideal.mul_mem_left (polynomial.C a) hx') hx,
      rwa [polynomial.monomial_eq_C_mul_X, pow_one, sub_sub_cancel,
        map_one, ← ideal.eq_top_iff_one] at this },
    rw ideal.mem_span_singleton_sup at this,
    obtain ⟨a, b, hb, e⟩ := this,
    have h : b.coeff 0 = 1,
    { apply_fun (λ p, polynomial.coeff p 0) at e,
      rwa [polynomial.coeff_add, polynomial.coeff_mul_X_zero, polynomial.coeff_one_zero,
      zero_add] at e },
    rw [ideal.mem_comap, polynomial.polynomial_algebra_of_algebra_algebra_map_apply,
      ideal.mem_span_singleton] at hb,
    obtain ⟨q, hq : b.map f = _⟩ := hb,
    refine ⟨b.reverse * polynomial.X ^ (1 + q.nat_degree), _, _⟩,
    { casesI subsingleton_or_nontrivial R with hR, { exact subsingleton.elim _ _ },
      rw [polynomial.monic, polynomial.leading_coeff_mul_X_pow, polynomial.reverse_leading_coeff,
        ← h, polynomial.trailing_coeff],
      congr' 1,
      exact le_zero_iff.mp (polynomial.nat_trailing_degree_le_of_ne_zero $ h.symm ▸ one_ne_zero) },
    { rw [polynomial.eval₂_eq_eval_map, polynomial.reverse, polynomial.map_mul,
        ← polynomial.reflect_map, polynomial.map_pow, polynomial.map_X,
        ← polynomial.rev_at_zero (1 + q.nat_degree), ← polynomial.reflect_monomial,
        ← polynomial.reflect_mul, pow_zero, mul_one, hq, ← add_assoc, polynomial.reflect_mul,
        polynomial.eval_mul, polynomial.reflect_sub, polynomial.reflect_C,
        polynomial.monomial_eq_C_mul_X, polynomial.reflect_C_mul_X_pow, polynomial.eval_sub,
        polynomial.eval_C_mul, polynomial.eval_C_mul, polynomial.eval_pow, polynomial.eval_X,
        polynomial.eval_pow, polynomial.eval_X, polynomial.rev_at_le, add_tsub_cancel_right,
        ← pow_succ, one_mul, sub_self, zero_mul],
      { exact le_add_self },
      { refine (polynomial.nat_degree_add_le _ _).trans (max_le _ _),
        { exact (polynomial.nat_degree_monomial_le _).trans le_add_self },
        { rw [← polynomial.C_neg, polynomial.nat_degree_C], exact zero_le _ } },
      { exact le_refl _ },
      { exact polynomial.nat_degree_map_le _ _ },
      { rw [pow_zero, polynomial.nat_degree_one], exact zero_le _ } } }
end

@[priority 100]
instance universally_closed.to_integral {X Y : Scheme} (f : X ⟶ Y) [H : integral f] :
  universally_closed f :=
by { rw integral_eq_affine_inf_universally_closed at H, exact H.2 }

instance integral_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [integral f] [integral g] : integral (f ≫ g) :=
integral_stable_under_composition _ _ infer_instance infer_instance

end algebraic_geometry


import category_theory.abelian.projective
import for_mathlib.homological_complex_shift
import tactic.linarith
import algebra.homology.quasi_iso
import algebra.homology.homotopy
import for_mathlib.abelian_category

.

open category_theory category_theory.limits

open_locale zero_object

section zero_object

variables {V : Type*} [category V] [has_zero_morphisms V]

noncomputable
lemma split_epi_of_is_zero {X Y : V} (f : X ⟶ Y) (h : is_zero Y) : split_epi f :=
⟨0, by simp [is_zero_iff_id_eq_zero.mp h]⟩

lemma epi_of_is_zero {X Y : V} (f : X ⟶ Y) (h : is_zero Y) : epi f :=
@@split_epi.epi _ (split_epi_of_is_zero f h)

noncomputable
lemma split_mono_of_is_zero {X Y : V} (f : X ⟶ Y) (h : is_zero X) : split_mono f :=
⟨0, by simp [is_zero_iff_id_eq_zero.mp h]⟩

lemma mono_of_is_zero_object {X Y : V} (f : X ⟶ Y) (h : is_zero X) : mono f :=
@@split_mono.mono _ (split_mono_of_is_zero f h)

lemma is_iso_of_is_zero {X Y : V} (f : X ⟶ Y)
  (h₁ : is_zero X) (h₂ : is_zero Y) : is_iso f :=
begin
  use 0,
  rw [is_zero_iff_id_eq_zero.mp h₁, is_zero_iff_id_eq_zero.mp h₂],
  split; simp
end

end zero_object

variables {V : Type*} [category V] [abelian V] [enough_projectives V] (X : cochain_complex V ℤ)
variables (a : ℤ) (H : ∀ i (h : a ≤ i), is_zero (X.X i))

lemma comp_eq_to_hom_heq_iff {C : Type*} [category C] {X X' Y Y' Y'' : C}
  (f : X ⟶ Y) (f' : X' ⟶ Y') (e : Y = Y'') : f ≫ eq_to_hom e == f' ↔ f == f' :=
by { subst e, erw category.comp_id }

lemma eq_to_hom_comp_heq_iff {C : Type*} [category C] {X X' Y Y' X'' : C}
  (f : X ⟶ Y) (f' : X' ⟶ Y') (e : X'' = X) : eq_to_hom e ≫ f == f' ↔ f == f' :=
by { subst e, erw category.id_comp }

lemma heq_eq_to_hom_comp_iff {C : Type*} [category C] {X X' Y Y' X'' : C}
  (f : X ⟶ Y) (f' : X' ⟶ Y') (e : X'' = X') : f == eq_to_hom e ≫ f' ↔ f == f' :=
by { subst e, erw category.id_comp }

lemma heq_comp_eq_to_hom_iff {C : Type*} [category C] {X X' Y Y' Y'' : C}
  (f : X ⟶ Y) (f' : X' ⟶ Y') (e : Y' = Y'') : f == f' ≫ eq_to_hom e ↔ f == f' :=
by { subst e, erw category.comp_id }

include H

namespace category_theory.projective

noncomputable
def replacement_aux : Π n : ℕ, Σ f : arrow V, (f.left ⟶ X.X (a-n))
| 0 := ⟨⟨0, 0, 0⟩, 0⟩
| (n+1) := ⟨⟨over
    (pullback (X.d (a-n-1) (a-n)) (kernel.ι (replacement_aux n).1.hom ≫ (replacement_aux n).2)),
  (replacement_aux n).1.left, π _ ≫ pullback.snd ≫ kernel.ι _⟩,
  π _ ≫ pullback.fst ≫ (X.X_eq_to_iso (by { norm_num, exact sub_sub _ _ _ })).hom⟩
.

lemma replacement_aux_right_eq (n : ℕ) :
  (replacement_aux X a H (n + 1)).1.right = (replacement_aux X a H n).1.left :=
by { delta replacement_aux, exact rfl }

lemma replacement_aux_hom_eq (n : ℕ) :
  (replacement_aux X a H (n + 1)).1.hom = eq_to_hom (by { delta replacement_aux, exact rfl }) ≫
    π (pullback (X.d (a-n-1) (a-n)) (kernel.ι
      (replacement_aux X a H n).1.hom ≫ (replacement_aux X a H n).2)) ≫
    pullback.snd ≫ kernel.ι (replacement_aux X a H n).1.hom ≫
    eq_to_hom (by { delta replacement_aux, exact rfl }) :=
by { delta replacement_aux, erw [category.id_comp, category.comp_id], exact rfl }
.

lemma replacement_aux_snd_comm (n : ℕ) :
  (replacement_aux X a H (n + 1)).1.hom ≫ eq_to_hom (replacement_aux_right_eq X a H n) ≫
    (replacement_aux X a H n).2 = (replacement_aux X a H (n + 1)).2 ≫ X.d _ _ :=
begin
  rw replacement_aux_hom_eq,
  simp only [category.id_comp, eq_to_hom_refl, category.assoc, eq_to_hom_trans_assoc],
  delta replacement_aux,
  rw [eq_to_hom_refl, category.id_comp, ← pullback.condition],
  erw [category.assoc, category.assoc, homological_complex.X_eq_to_iso_d],
end

noncomputable
def replacement : cochain_complex V ℤ :=
{ X := λ i, if a < i then 0 else (replacement_aux X a H ((a - i).nat_abs + 1)).1.right,
  d := λ i j, if h₁ : i + 1 = j then if h₂ : j > a then 0 else
      eq_to_hom (begin
        rw [if_neg, replacement_aux_right_eq, functor.id_obj],
        subst h₁,
        suffices : (a - i).nat_abs = (a - (i + 1)).nat_abs + 1,
        { rw this },
        apply int.coe_nat_inj,
        norm_num [← int.abs_eq_nat_abs],
        rw [abs_eq_self.mpr _, abs_eq_self.mpr _],
        all_goals { linarith }
      end) ≫
      (replacement_aux X a H ((a - j).nat_abs + 1)).fst.hom ≫ eq_to_hom (dif_neg h₂).symm else 0,
  shape' := λ _ _ e, dif_neg e,
  d_comp_d' := begin
    rintros i j k (rfl : i+1 = j) (rfl : i+1+1 = k),
    simp only [dif_pos, dif_ctx_congr],
    by_cases h : i + 1 + 1 > a,
    { rw [dif_pos h, comp_zero] },
    rw [dif_neg h, dif_neg],
    rw [← category.assoc, ← category.assoc, ← is_iso.eq_comp_inv],
    simp only [category.assoc, eq_to_hom_trans_assoc],
    rw [← is_iso.eq_inv_comp, zero_comp, comp_zero, replacement_aux_hom_eq],
    simp only [category.assoc, eq_to_hom_trans_assoc],
    iterate 3 { convert comp_zero },
    suffices : (a - (i + 1)).nat_abs = (a - (i + 1 + 1)).nat_abs + 1,
    { convert kernel.condition _; try { rw this }, apply (eq_to_hom_comp_heq_iff _ _ _).mpr,
      congr; rw this },
    apply int.coe_nat_inj,
    norm_num [← int.abs_eq_nat_abs],
    rw [abs_eq_self.mpr _, abs_eq_self.mpr _],
    all_goals { linarith }
  end }

noncomputable
def replacement.hom : replacement X a H ⟶ X :=
{ f := λ i, if h : a < i then 0 else eq_to_hom (if_neg h) ≫
    eq_to_hom (by rw replacement_aux_right_eq) ≫
    (replacement_aux X a H ((a - i).nat_abs)).snd ≫
    (X.X_eq_to_iso (by { rw [← int.abs_eq_nat_abs, sub_eq_iff_eq_add, ← sub_eq_iff_eq_add',
      eq_comm, abs_eq_self], linarith })).hom,
  comm' := begin
    rintros i j (rfl : i+1 = j),
    split_ifs with h',
    { rw [zero_comp, comp_zero] },
    { exfalso, linarith },
    { rw comp_zero, apply (H _ (le_of_lt h)).eq_of_tgt },
    { dsimp only [replacement],
      rw [dif_pos rfl, dif_neg h],
      simp only [← category.assoc, eq_to_hom_trans_assoc],
      rw [← is_iso.comp_inv_eq],
      simp only [homological_complex.X_d_eq_to_iso, homological_complex.X_eq_to_iso_inv,
        category.assoc, homological_complex.X_eq_to_iso_d, eq_to_hom_trans, is_iso.iso.inv_hom],
      rw [← is_iso.inv_comp_eq, inv_eq_to_hom, eq_to_hom_trans_assoc],
      refine eq.trans _ (replacement_aux_snd_comm X a H _).symm,
      suffices : (a - (i + 1)).nat_abs + 1 = (a - i).nat_abs,
      { rw ← heq_iff_eq, apply (eq_to_hom_comp_heq_iff _ _ _).mpr, rw this },
      apply int.coe_nat_inj,
      norm_num [← int.abs_eq_nat_abs],
      rw [abs_eq_self.mpr _, abs_eq_self.mpr _],
      all_goals { linarith } }
  end }

omit H
variables {V} {A B C : V} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0)
variables {A' B' C' : V} {f' : A' ⟶ B'} {g' : B' ⟶ C'} (w' : f' ≫ g' = 0)
variables (α : arrow.mk f ⟶ arrow.mk f') (β : arrow.mk g ⟶ arrow.mk g')
variables (p : α.right = β.left)

instance : epi (homology.π f g w) :=
by { delta homology.π, apply_instance }

instance : strong_epi (factor_thru_image f) :=
strong_epi_factor_thru_image_of_strong_epi_mono_factorisation $
      classical.choice $ has_strong_epi_mono_factorisations.has_fac f

instance : epi (factor_thru_image f ≫ (image_subobject_iso f).inv) :=
epi_comp _ _

instance : mono (homology.ι f g w) :=
by { delta homology.ι, apply_instance }

@[simp, reassoc]
lemma π_cokernel_iso_of_eq {f₁ f₂ : A ⟶ B} (e : f₁ = f₂) :
  cokernel.π f₁ ≫ (cokernel_iso_of_eq e).hom = cokernel.π f₂ :=
by { subst e, erw has_colimit.iso_of_nat_iso_ι_hom, exact category.id_comp _ }

@[simp, reassoc]
lemma homology.π_iso_cokernel_lift_hom :
  homology.π f g w ≫ (homology_iso_cokernel_lift f g w).hom =
    (kernel_subobject_iso _).hom ≫ cokernel.π _ :=
begin
  simp only [limits.cokernel_epi_comp_inv, iso.symm_hom, homology_iso_cokernel_lift,
    iso.trans_hom],
  erw homology.π_desc_assoc,
  simp only [cokernel.π_desc_assoc, category.assoc, iso.cancel_iso_hom_left,
    π_cokernel_iso_of_eq],
end

@[simp, reassoc]
lemma homology.π'_ι :
  homology.π' f g w ≫ homology.ι f g w = kernel.ι g ≫ cokernel.π f :=
by { delta homology.π' homology.ι homology_iso_kernel_desc, simp }

@[simp, reassoc]
lemma homology.π_ι :
  homology.π f g w ≫ homology.ι f g w = (kernel_subobject _).arrow ≫ cokernel.π _ :=
by rw [← homology.π'_eq_π, category.assoc, homology.π'_ι, kernel_subobject_arrow_assoc]

open_locale pseudoelement
open category_theory.abelian

lemma mono_homology_map_of_pseudoelement
  (H : ∀ (x : B) (y : A') (h₁ : g x = 0) (h₂ : f' y = α.right x), ∃ z : A, f z = x) :
  mono (homology.map w w' α β p) :=
begin
  apply pseudoelement.mono_of_zero_of_map_zero,
  intros x e,
  obtain ⟨x', rfl⟩ := pseudoelement.pseudo_surjective_of_epi (homology.π f g w) x,
  rw [← pseudoelement.comp_apply, homology.π_map, pseudoelement.comp_apply] at e,
  obtain ⟨y, hy⟩ := (@pseudoelement.pseudo_exact_of_exact _ _ _ _ _ _ _
    (homology.π f' g' w') (exact_cokernel _)).2 _ e,
  obtain ⟨y', rfl⟩ := pseudoelement.pseudo_surjective_of_epi
    (factor_thru_image f' ≫ (image_subobject_iso _).inv) y,
  obtain ⟨z, e'⟩ := H ((kernel_subobject g).arrow x') y'
    (by rw [← pseudoelement.comp_apply, kernel_subobject_arrow_comp, pseudoelement.zero_apply])
    (by simpa [← pseudoelement.comp_apply, p] using congr_arg (kernel_subobject g').arrow hy),
  have : f = (factor_thru_image f ≫ (image_subobject_iso _).inv ≫ image_to_kernel f g w) ≫
    (kernel_subobject g).arrow := by simp,
  rw [this, pseudoelement.comp_apply] at e',
  have := pseudoelement.pseudo_injective_of_mono _ e', subst this,
  simp [← pseudoelement.comp_apply]
end
.
lemma mono_homology_map_of_epi_pullback_lift
  (H : epi (pullback.lift _ _
    (show α.left ≫ f' = (kernel.lift g f w) ≫ kernel.ι _ ≫ α.right, by simp))) :
  mono (homology.map w w' α β p) :=
begin
  apply mono_homology_map_of_pseudoelement,
  intros x y e₁ e₂,
  obtain ⟨x', rfl⟩ := (@pseudoelement.pseudo_exact_of_exact _ _ _ _ _ _ _ _ exact_kernel_ι).2 x e₁,
  rw ← pseudoelement.comp_apply at e₂,
  obtain ⟨z, rfl, rfl⟩ := pseudoelement.pseudo_pullback e₂,
  obtain ⟨z', rfl⟩ := @@pseudoelement.pseudo_surjective_of_epi _ _ _ H z,
  use z',
  simp [← pseudoelement.comp_apply]
end
.

lemma epi_homology_map_of_pseudoelement
  (H : ∀ (x : B') (h : g' x = 0),
    ∃ (y : B), g y = 0 ∧ (cokernel.π f') (α.right y) = cokernel.π f' x) :
  epi (homology.map w w' α β p) :=
begin
  apply pseudoelement.epi_of_pseudo_surjective,
  intro x,
  obtain ⟨x', rfl⟩ := pseudoelement.pseudo_surjective_of_epi (homology.π f' g' w') x,
  obtain ⟨y, e₁, e₂⟩ := H ((kernel_subobject g').arrow x')
    (by rw [← pseudoelement.comp_apply, kernel_subobject_arrow_comp, pseudoelement.zero_apply]),
  obtain ⟨y', rfl⟩ := (@pseudoelement.pseudo_exact_of_exact _ _ _ _ _ _ _ _
    exact_kernel_subobject_arrow).2 y e₁,
  use homology.π f g w y',
  apply pseudoelement.pseudo_injective_of_mono (homology.ι f' g' w'),
  simpa [← pseudoelement.comp_apply, p] using e₂,
end

local attribute [instance] epi_comp mono_comp

noncomputable
def pullback_comp_mono_iso {X Y Z Z' : V} (f : X ⟶ Z) (g : Y ⟶ Z) (h : Z ⟶ Z') [mono h] :
  pullback (f ≫ h) (g ≫ h) ≅ pullback f g :=
limit.iso_limit_cone ⟨_, pullback_is_pullback_of_comp_mono f g h⟩

@[simp, reassoc]
lemma pullback_comp_mono_iso_fst {X Y Z Z' : V} (f : X ⟶ Z) (g : Y ⟶ Z) (h : Z ⟶ Z') [mono h] :
  (pullback_comp_mono_iso f g h).hom ≫ pullback.fst = pullback.fst :=
limit.iso_limit_cone_hom_π _ walking_cospan.left

lemma kernel_ι_replacement_aux_eq_zero (i : ℕ) :
  kernel.ι (replacement_aux X a H i).fst.hom ≫ (replacement_aux X a H i).snd ≫
    X.d (a - i) (a - i + 1) = 0 :=
begin
  cases i,
  { dsimp [replacement_aux], simp },
  { have : a - i.succ + 1 = a - i, { norm_num [sub_add] },
    rw [this, ← replacement_aux_snd_comm, kernel.condition_assoc, zero_comp] }
end

instance replacement_kernel_map_epi (i : ℕ) : epi (kernel.lift (X.d (a - i) (a - i + 1))
    (kernel.ι (replacement_aux X a H i).fst.hom ≫ (replacement_aux X a H i).snd)
    (by rw [category.assoc, kernel_ι_replacement_aux_eq_zero])) :=
begin
  cases i,
  { apply epi_of_is_zero,
    refine is_zero_of_mono (kernel.ι _) _,
    { apply H, simp }, },
  { apply pseudoelement.epi_of_pseudo_surjective,
    intro x,
    obtain ⟨y, h₁, h₂⟩ := @pseudoelement.pseudo_pullback _ _ _ _ _ _ _ (X.d (a - i - 1) (a - i))
      (kernel.ι (replacement_aux X a H i).fst.hom ≫ (replacement_aux X a H i).snd)
      ((X.X_eq_to_iso (by norm_num [sub_sub])).hom (kernel.ι (X.d _ _) x)) 0 _,
    swap,
    { simp only [← pseudoelement.comp_apply, category.assoc,
        homological_complex.X_eq_to_iso_d, pseudoelement.apply_zero],
      convert pseudoelement.zero_apply _ _,
      have : a - ↑i = a - ↑(i + 1) + 1 := by norm_num [← sub_sub],
      convert kernel.condition _ },
    obtain ⟨z, rfl⟩ := pseudoelement.pseudo_surjective_of_epi (projective.π _) y,
    apply_fun kernel.ι (replacement_aux X a H i).fst.hom at h₂,
    simp only [← pseudoelement.comp_apply, category.assoc, pseudoelement.apply_zero] at h₂,
    obtain ⟨w, rfl⟩ := (@pseudoelement.pseudo_exact_of_exact _ _ _ _ _ _ _ _
      exact_kernel_ι).2 z h₂,
    dsimp [replacement_aux],
    use w,
    simp only [← pseudoelement.comp_apply] at h₁,
    apply pseudoelement.pseudo_injective_of_mono (kernel.ι (X.d (a - ↑(i + 1))
      (a - ↑(i + 1) + 1)) ≫ (homological_complex.X_eq_to_iso X _).hom),
    refine eq.trans _ h₁,
    simp only [← pseudoelement.comp_apply, category.assoc],
    congr' 1,
    refine (kernel.lift_ι_assoc _ _ _ _).trans _,
    simpa,
    apply_instance }
end

instance (i : ℕ) : epi (replacement_aux X a H i).snd :=
begin
  cases i; dsimp [replacement_aux],
  { apply epi_of_is_zero, apply H, simp },
  { apply_with epi_comp { instances := ff },
    { apply_instance },
    apply_with epi_comp { instances := ff },
    swap, { apply_instance },
    let e : pullback (X.d (a - i - 1) (a - i))
      (kernel.ι (replacement_aux X a H i).fst.hom ≫ (replacement_aux X a H i).snd) ≅
        pullback (kernel.lift (X.d (a - i) (a - i + 1)) _ _) (kernel.lift _ _ _),
    { refine pullback.congr_hom (kernel.lift_ι _ _ (X.d_comp_d _ _ _)).symm
        (kernel.lift_ι _ _ _).symm ≪≫ pullback_comp_mono_iso _ _ (kernel.ι _),
      rw [category.assoc, kernel_ι_replacement_aux_eq_zero] },
    have : e.hom ≫ pullback.fst = pullback.fst,
    { simp },
    refine (eq_iff_iff.mp (congr_arg epi this)).mp _,
    apply_instance },
end

noncomputable
def homology_functor_obj_iso (X) (i : ℤ) :
  (homology_functor V (complex_shape.up ℤ) i).obj X ≅ homology _ _ (X.d_comp_d (i-1) i (i+1)) :=
homology.map_iso _ _
  (arrow.iso_mk (X.X_prev_iso (sub_add_cancel _ _)) (iso.refl _) (by { dsimp, simp [← X.d_to_eq] }))
  (arrow.iso_mk (iso.refl _) (X.X_next_iso rfl) (by { dsimp, simp })) (by { dsimp, simp})

lemma homology_functor_map_iso {X Y : cochain_complex V ℤ} (f : X ⟶ Y) (i : ℤ) :
  (homology_functor V (complex_shape.up ℤ) i).map f =
    (homology_functor_obj_iso X i).hom ≫
    homology.map _ _ (arrow.hom_mk (f.comm _ _)) (arrow.hom_mk (f.comm _ _)) rfl ≫
    (homology_functor_obj_iso Y i).inv :=
begin
  delta homology_functor_obj_iso homology.map_iso,
  simp only [homology_functor_map, homology.map_comp],
  congr; ext; dsimp,
  { rw homological_complex.hom.prev_eq, },
  { simp only [category.comp_id, category.id_comp] },
  { simp only [category.comp_id, category.id_comp] },
  { rw homological_complex.hom.next_eq, },
end

lemma mono_homology_functor_of_pseudoelement (i : ℤ) {X Y : cochain_complex V ℤ} (f : X ⟶ Y)
  (H : ∀ (x : X.X i) (y : Y.X (i - 1)), X.d i (i + 1) x = 0 → Y.d (i - 1) i y = f.f i x →
    (∃ (z : X.X (i - 1)), X.d (i - 1) i z = x)) :
  mono ((homology_functor V (complex_shape.up ℤ) i).map f) :=
begin
  haveI := mono_homology_map_of_pseudoelement _ _ (X.d_comp_d (i-1) i (i+1))
    (Y.d_comp_d (i-1) i (i+1)) (arrow.hom_mk (f.comm _ _)) (arrow.hom_mk (f.comm _ _)) rfl H,
  rw homology_functor_map_iso,
  apply_instance
end

local attribute [instance] pseudoelement.setoid

lemma pseudoelement.id_apply {X : V} (x : X) : @@coe_fn _ pseudoelement.hom_to_fun (𝟙 X) x = x :=
begin
  apply quot.induction_on x,
  intro a,
  change ⟦over.mk _⟧ = ⟦a⟧,
  erw category.comp_id,
  rcases a with ⟨_, ⟨⟨⟩⟩, _⟩,
  congr,
end

lemma replacement_aux_comp_eq_zero (i : ℕ) :
  (replacement_aux X a H (i+1)).fst.hom ≫ eq_to_hom (by { dsimp [replacement_aux], refl }) ≫
  (replacement_aux X a H i).fst.hom = 0 :=
begin
  dsimp [replacement_aux],
  simp only [category.assoc, category.id_comp],
  refine (category.assoc _ _ _).symm.trans (eq.trans _ comp_zero),
  swap 3,
  congr' 1,
  exact kernel.condition (replacement_aux X a H i).fst.hom,
end

noncomputable
def replacement_homology_map (i : ℕ) :
  homology _ _ ((category.assoc _ _ _).trans (replacement_aux_comp_eq_zero X a H (i+1))) ⟶
  homology _ _ (X.d_comp_d (a-(i+1 : ℕ) - 1) (a-(i+1 : ℕ)) (a-i)) :=
begin
  refine homology.map _ _ _ (arrow.hom_mk (replacement_aux_snd_comm X a H i).symm) _,
  { have := (replacement_aux_snd_comm X a H (i+1)).symm.trans (category.assoc _ _ _).symm,
    have hai : a - ↑(i + 2) = a - ↑(i + 1) - 1, { push_cast, ring },
    rw [← X.X_eq_to_iso_d hai, ← category.assoc] at this,
    exact arrow.hom_mk this, },
  { apply_instance }, { refl }
end

instance (i : ℕ) : mono (replacement_homology_map X a H i) :=
begin
  apply mono_homology_map_of_epi_pullback_lift,
  dsimp [replacement_aux],
  convert projective.π_epi _,
  apply pullback.hom_ext,
  { simpa only [category.comp_id, category.assoc, arrow.hom_mk_left, X.X_eq_to_iso_trans,
      X.X_eq_to_iso_refl, pullback.lift_fst] },
  { refine (cancel_mono (kernel.ι _)).mp _,
    simp only [category.comp_id, category.assoc, arrow.hom_mk_left, kernel.lift_ι,
      X.X_eq_to_iso_trans, pullback.lift_snd, X.X_eq_to_iso_refl],
    simp_rw ← category.assoc,
    exact category.comp_id _ },
end
.

lemma comp_left_epi_iff {V : Type*} [category V] {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) [epi f] :
  epi (f ≫ g) ↔ epi g :=
⟨λ h, @@epi_of_epi _ _ _ h, λ h, @@epi_comp _ _ _ _ h⟩

lemma comp_right_epi_iff {V : Type*} [category V] {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso g] :
  epi (f ≫ g) ↔ epi f :=
⟨λ h, by simpa using @@epi_comp _ (f ≫ g) h (inv g) _, λ h, @@epi_comp _ _ h _ _⟩

instance replacement_kernel_map_epi' (i : ℕ) :
  epi (kernel.lift (X.d (a - (i + 1)) (a - i))
    (kernel.ι (replacement_aux X a H (i + 1)).fst.hom ≫ (replacement_aux X a H (i + 1)).snd)
    (by { rw category.assoc,
      convert kernel_ι_replacement_aux_eq_zero X a H _; norm_num [sub_add] })) :=
begin
  convert projective.replacement_kernel_map_epi X a H _; norm_num [sub_add]
end

instance (i : ℕ) : epi (replacement_homology_map X a H i) :=
begin
  apply_with (epi_of_epi (homology.π _ _ _)) { instances := ff },
  erw homology.π_map,
  apply_with epi_comp { instances := ff },
  swap, { apply_instance },
  rw [← comp_left_epi_iff (kernel_subobject_iso _).inv,
    ← comp_right_epi_iff _ (kernel_subobject_iso _).hom],
  convert projective.replacement_kernel_map_epi' X a H _ using 1,
  refine (cancel_mono (kernel.ι _)).mp _,
  simp only [kernel_subobject_arrow'_assoc, category.assoc, kernel_subobject_map_arrow,
    kernel_subobject_arrow, arrow.hom_mk_left],
  erw kernel.lift_ι,
  apply_instance
end

instance (i : ℕ) : is_iso (replacement_homology_map X a H i) :=
is_iso_of_mono_of_epi _

lemma replacement_aux_eq_of_eq (i j : ℕ) (e : i + 1 = j) :
  (replacement_aux X a H j).1.right = (replacement_aux X a H i).1.left :=
begin
  subst e,
  dsimp [replacement_aux],
  refl
end

lemma replacement_aux_fst_hom_congr (i j : ℕ) (e : i = j) :
  (replacement_aux X a H i).1.hom == (replacement_aux X a H j).1.hom :=
by { subst e }

lemma replacement_aux_snd_congr (i j : ℕ) (e : i = j) :
  (replacement_aux X a H i).2 == (replacement_aux X a H j).2 :=
by { subst e }

lemma replacement_homology_eq (i : ℕ) :
  homology _ _ ((replacement X a H).d_comp_d (a - ↑(i + 1) - 1) (a - ↑(i + 1)) (a - i)) =
    homology _ _ (replacement_homology_map._proof_4 X a H i) :=
begin
  dsimp only [replacement],
  have e₁ : a - (↑i + 1) - 1 + 1 = a - (↑i + 1) := by norm_num [sub_add],
  have e₂ : a - (↑i + 1) + 1 = a - ↑i := by norm_num [sub_add],
  have e₃ : ¬ a < a - (↑i + 1) - 1 :=
    by { simp only [tsub_le_iff_right, not_lt], linarith },
  have e₄ : ¬a - (↑i + 1) > a := by { simp only [gt_iff_lt, tsub_le_iff_right, not_lt], linarith },
  have e₅ : ¬a - i > a := by { simp only [gt_iff_lt, tsub_le_iff_right, not_lt], linarith },
  have e₆ : (a - (a - (↑i + 1))).nat_abs = i + 1,
  { rw [← sub_add, sub_self, zero_add], exact int.nat_abs_of_nat_core _ },
  have e₇ : (a - (a - (↑i + 1) - 1)).nat_abs = i + 1 + 1,
  { rw [sub_sub, ← sub_add, sub_self, zero_add], exact int.nat_abs_of_nat_core _ },
  have e₈ : (a - (a - i)).nat_abs = i := by norm_num,
  simp only [nat.cast_add, nat.cast_one, sub_add_cancel, eq_self_iff_true, gt_iff_lt, dif_pos,
    not_lt, sub_le_self_iff, nat.cast_nonneg, dif_neg, eq_to_hom_refl, category.comp_id],
  simp only [dif_pos e₁, dif_pos e₂, dif_neg e₄, dif_neg e₅],
  congr' 1,
  { erw if_neg e₃, apply replacement_aux_eq_of_eq, erw e₇ },
  { erw if_neg e₄, apply replacement_aux_eq_of_eq, erw e₆ },
  { erw if_neg e₅, { congr, { ext, congr, exact e₈ }, { exact e₈ } } },
  { erw [eq_to_hom_comp_heq_iff, comp_eq_to_hom_heq_iff, e₆] },
  { erw [eq_to_hom_comp_heq_iff, comp_eq_to_hom_heq_iff, e₈] },
end

lemma replacement_hom_homology_iso (i : ℕ) :
  homology.map ((replacement X a H).d_comp_d _ _ _) (X.d_comp_d _ _ _)
    (arrow.hom_mk ((replacement.hom X a H).comm _ _))
    (arrow.hom_mk ((replacement.hom X a H).comm _ _)) rfl =
  (eq_to_hom (replacement_homology_eq X a H i)) ≫ replacement_homology_map X a H i :=
begin
  rw [← heq_iff_eq, heq_eq_to_hom_comp_iff],
  delta replacement_homology_map,
  dsimp [replacement],
  congr' 3,
  any_goals { rw if_neg, apply replacement_aux_eq_of_eq,
    { norm_num [← sub_add], exact (int.nat_abs_of_nat_core _).symm },
    { simp only [gt_iff_lt, tsub_le_iff_right, not_lt], linarith } },
  any_goals { rw if_neg, dsimp [replacement_aux], congr, { ext, congr, norm_num }, { norm_num },
    { simp only [gt_iff_lt, tsub_le_iff_right, not_lt], linarith } },
  any_goals { rw category.comp_id },
  any_goals { rw heq_eq_to_hom_comp_iff},
  any_goals { delta homological_complex.X_eq_to_iso, erw heq_comp_eq_to_hom_iff },
  any_goals { dsimp [replacement.hom],
    rw [dif_neg, eq_to_hom_comp_heq_iff, eq_to_hom_comp_heq_iff],
    erw comp_eq_to_hom_heq_iff,
    { apply replacement_aux_snd_congr,
      refine eq.trans _ (int.nat_abs_of_nat_core _),
      congr' 1,
      norm_num [sub_sub, sub_add] },
    { simp only [gt_iff_lt, tsub_le_iff_right, not_lt], linarith } },
  all_goals { rw [dif_pos, dif_neg, eq_to_hom_comp_heq_iff, comp_eq_to_hom_heq_iff],
    apply replacement_aux_fst_hom_congr,
    { congr' 1,
      refine eq.trans _ (int.nat_abs_of_nat_core _),
      congr' 1,
      norm_num [sub_sub, sub_add] },
    { simp only [gt_iff_lt, tsub_le_iff_right, not_lt], linarith },
    { norm_num [sub_sub, sub_add] } },
end
.

lemma homology_functor_map_iso' {X Y : cochain_complex V ℤ} (f : X ⟶ Y) (i j k : ℤ)
  (e₁ : i + 1 = j) (e₂ : j + 1 = k) :
  (homology_functor V (complex_shape.up ℤ) j).map f =
    (homology_functor_obj_iso X _).hom ≫
      (eq_to_hom $ by { have e₁ : i = j - 1 := by simp [← e₁], substs e₁ e₂ }) ≫
    homology.map (X.d_comp_d i j k) (Y.d_comp_d i j k)
      (arrow.hom_mk (f.comm i j)) (arrow.hom_mk (f.comm j k)) rfl ≫
    (eq_to_hom $ by { have e₁ : i = j - 1 := by simp [← e₁], substs e₁ e₂ }) ≫
      (homology_functor_obj_iso Y _).inv :=
begin
  have e₁ : i = j - 1 := by simp [← e₁], substs e₁ e₂,
  erw [category.id_comp, category.id_comp],
  rw homology_functor_map_iso
end

include H

lemma homology_is_zero_of_bounded (i : ℤ) (e : a ≤ i) :
  is_zero ((homology_functor V (complex_shape.up ℤ) i).obj X) :=
begin
  apply is_zero_of_mono (homology_iso_cokernel_image_to_kernel' _ _ _).hom,
  apply is_zero_of_epi (cokernel.π _),
  apply is_zero_of_mono (kernel.ι _),
  apply H i e,
  all_goals { apply_instance }
end

omit H

lemma replacement_is_projective (i : ℤ) : projective ((replacement X a H).X i) :=
begin
  dsimp [replacement],
  split_ifs,
  { apply_instance },
  { dsimp [replacement_aux],
    induction (a - i).nat_abs; dsimp [replacement_aux]; apply_instance }
end

instance (i : ℤ) : epi ((replacement.hom X a H).f i) :=
begin
  dsimp [replacement.hom],
  split_ifs,
  { apply epi_of_is_zero, apply H, exact le_of_lt h },
  { apply_instance }
end

lemma replacement_is_bounded : ∀ i (h : a ≤ i), is_zero ((replacement X a H).X i) :=
begin
  intros i h,
  dsimp [replacement],
  split_ifs,
  { exact is_zero_zero _ },
  { have : a = i := by linarith, subst this,
    rw [sub_self, int.nat_abs_zero],
    dsimp [replacement_aux],
    exact is_zero_zero _ }
end

instance : quasi_iso (replacement.hom X a H) :=
begin
  constructor,
  intro i,
  rw ← sub_add_cancel i a,
  induction (i - a) with i i,
  { apply is_iso_of_is_zero,
    exact homology_is_zero_of_bounded _ a (replacement_is_bounded X a H) _ (by simp),
    exact homology_is_zero_of_bounded _ a H _ (by simp) },
  { rw (show (-[1+ i] + a) = (a - ↑(i + 1)), by { rw [add_comm], refl }),
    rw homology_functor_map_iso' _ (a - ↑(i + 1) - 1) (a - ↑(i + 1)) (a - i),
    { rw replacement_hom_homology_iso X a H i,
      apply_instance },
    { norm_num },
    { norm_num [sub_add] },
    apply_instance }
end
.

@[simps]
def _root_.cochain_complex.as_nat_chain_complex (X : cochain_complex V ℤ) (a : ℤ) :
  chain_complex V ℕ :=
{ X := λ i, X.X (a - i),
  d := λ i j, X.d _ _,
  shape' := λ i j r, by { refine X.shape _ _ (λ e, r _), dsimp at e ⊢,
    apply int.coe_nat_inj, push_cast, linarith },
  d_comp_d' := λ i j k _ _, X.d_comp_d _ _ _ }

@[simps]
def _root_.cochain_complex.to_nat_chain_complex (a : ℤ) :
  cochain_complex V ℤ ⥤ chain_complex V ℕ :=
{ obj := λ X, X.as_nat_chain_complex a,
  map := λ X Y f, { f := λ i, f.f _ } }

lemma is_zero_iff_iso_zero (X : V) :
  is_zero X ↔ nonempty (X ≅ 0) :=
⟨λ e, ⟨e.iso_zero⟩, λ ⟨e⟩, is_zero_of_iso_of_zero (is_zero_zero _) e.symm⟩

lemma preadditive.exact_iff_homology_is_zero {X Y Z : V} (f : X ⟶ Y) (g : Y ⟶ Z) :
  exact f g ↔ ∃ w, is_zero (homology f g w) :=
begin
  rw preadditive.exact_iff_homology_zero,
  simp_rw is_zero_iff_iso_zero,
end

noncomputable
def null_homotopic_of_projective_to_acyclic_aux {X Y : cochain_complex V ℤ} (f : X ⟶ Y) (a : ℤ)
  (h₁ : ∀ i, projective (X.X i))
  (h₂ : ∀ i, a ≤ i → is_zero (X.X i))
  (h₃ : ∀ i, is_zero ((homology_functor _ _ i).obj Y)) :
  homotopy ((cochain_complex.to_nat_chain_complex a).map f) 0 :=
begin
  have h₄ : ∀ i, a ≤ i → f.f i = 0,
  { intros i e, apply (h₂ i e).eq_of_src },
  fapply homotopy.mk_inductive _ 0,
  { dsimp, rw zero_comp, apply h₄, push_cast, linarith },
  all_goals { dsimp },
  { have := f.comm (a - (0 + 1)) a,
    rw [h₄ _ (le_of_eq rfl), comp_zero] at this,
    refine projective.factor_thru (kernel.lift _ _ this) _,
    exact kernel.lift _ _ (Y.d_comp_d _ _ _),
    { apply_with kernel.lift.epi { instances := ff },
      rw preadditive.exact_iff_homology_is_zero,
      refine ⟨Y.d_comp_d _ _ _,
        is_zero_of_iso_of_zero (h₃ (a - (0 + 1))) (homology_iso _ _ _ _ _ _)⟩,
      all_goals { dsimp, abel } } },
  { rw comp_zero, conv_rhs { rw [zero_add] },
    slice_rhs 2 3 { erw ← kernel.lift_ι _ _ (Y.d_comp_d (a - (0 + 1 + 1)) (a - (0 + 1)) a) },
    erw [← category.assoc, projective.factor_thru_comp, kernel.lift_ι], refl },
  { rintros n ⟨g₁, g₂, e⟩, dsimp only,
    have : X.d (a - (n + 1 + 1)) (a - (n + 1)) ≫
      (f.f (a - (↑n + 1)) - g₂ ≫ Y.d (a - (↑n + 1 + 1)) (a - (↑n + 1))) = 0,
    { rw ← sub_eq_iff_eq_add at e, erw [e, X.d_comp_d_assoc, zero_comp] },
    rw [preadditive.comp_sub, ← f.comm, ← category.assoc, ← preadditive.sub_comp] at this,
    fsplit,
    { refine projective.factor_thru (kernel.lift _ _ this) _,
      exact kernel.lift _ _ (Y.d_comp_d _ _ _),
      apply_with kernel.lift.epi { instances := ff },
      rw preadditive.exact_iff_homology_is_zero,
      refine ⟨Y.d_comp_d _ _ _, is_zero_of_iso_of_zero (h₃ _) (homology_iso _ _ _ _ _ _)⟩,
      all_goals { dsimp, push_cast, abel } },
    { rw ← sub_eq_iff_eq_add',
      slice_rhs 2 3 { erw ← kernel.lift_ι (Y.d (a-(n+1+1)) (a-(n+1))) _ (Y.d_comp_d _ _ _) },
      erw [← category.assoc, projective.factor_thru_comp, kernel.lift_ι], refl } }
end

noncomputable
def null_homotopic_of_projective_to_acyclic {X Y : cochain_complex V ℤ} (f : X ⟶ Y) (a : ℤ)
  (h₁ : ∀ i, projective (X.X i))
  (h₂ : ∀ i, a ≤ i → is_zero (X.X i))
  (h₃ : ∀ i, is_zero ((homology_functor _ _ i).obj Y)) :
  homotopy f 0 :=
{ hom := λ i j, if h : i ≤ a ∧ j ≤ a then begin
    refine (X.X_eq_to_iso _).hom ≫ (null_homotopic_of_projective_to_acyclic_aux f a h₁ h₂ h₃).hom
      (a - i).nat_abs (a - j).nat_abs ≫ (Y.X_eq_to_iso _).hom,
    swap, symmetry,
    all_goals { rw [← int.abs_eq_nat_abs, eq_sub_iff_add_eq, ← eq_sub_iff_add_eq', abs_eq_self],
      cases h, rwa sub_nonneg }
  end else 0,
  zero' := begin
    intros i j e,
    split_ifs,
    { cases h,
      rw [(null_homotopic_of_projective_to_acyclic_aux f a h₁ h₂ h₃).zero, zero_comp, comp_zero],
      intro e', apply e,
      dsimp at e' ⊢,
      apply_fun (coe : ℕ → ℤ) at e',
      rw [int.coe_nat_add, ← int.abs_eq_nat_abs, ← int.abs_eq_nat_abs, abs_eq_self.mpr _,
        abs_eq_self.mpr _, int.coe_nat_one, sub_add, sub_right_inj] at e',
      rw [← e', sub_add_cancel],
      all_goals { rwa sub_nonneg } },
    { refl }
  end,
  comm := begin
    intros i,
    rw [d_next_eq _ (show (complex_shape.up ℤ).rel i (i+1), from rfl),
      prev_d_eq _ (show (complex_shape.up ℤ).rel (i-1) i, from sub_add_cancel _ _)],
    have e₁ : i + 1 ≤ a ∧ i ≤ a ↔ i + 1 ≤ a := by { rw and_iff_left_iff_imp, intro e, linarith },
    have e₂ : i ≤ a ∧ i ≤ a + 1 ↔ i ≤ a := by { rw and_iff_left_iff_imp, intro e, linarith },
    simp only [tsub_le_iff_right, homological_complex.zero_f_apply, add_zero, e₁, e₂],
    by_cases H₁ : a ≤ i, { apply (h₂ _ H₁).eq_of_src, },
    replace H₁ : i + 1 ≤ a, { linarith only [H₁] },
    have H₂ : i ≤ a, { linarith only [H₁] },
    rw [dif_pos H₁, dif_pos H₂],
    have e : a - (a - i).nat_abs = i,
    { rw [← int.abs_eq_nat_abs, abs_eq_self.mpr _, ← sub_add, sub_self, zero_add],
      rwa sub_nonneg },
    rw [← cancel_mono (Y.X_eq_to_iso e.symm).hom, ← cancel_epi (X.X_eq_to_iso e).hom],
    have := (null_homotopic_of_projective_to_acyclic_aux f a h₁ h₂ h₃).comm (a - i).nat_abs,
    dsimp [from_next, to_prev] at this ⊢,
    simp only [homological_complex.X_d_eq_to_iso_assoc, category.comp_id, add_zero,
      homological_complex.X_d_eq_to_iso, category.id_comp,
      homological_complex.X_eq_to_iso_d_assoc, homological_complex.X_eq_to_iso_trans_assoc,
      preadditive.comp_add, category.assoc, homological_complex.X_eq_to_iso_d,
      homological_complex.X_eq_to_iso_trans, homological_complex.X_eq_to_iso_f_assoc,
      homological_complex.X_eq_to_iso_refl, preadditive.add_comp] at this ⊢,
    rw this, clear this,
    delta homological_complex.d_from homological_complex.d_to cochain_complex.as_nat_chain_complex,
    dsimp only,
    have aux₁ : (complex_shape.down ℕ).next (a - i).nat_abs = (a - (i + 1)).nat_abs,
    { apply complex_shape.next_eq',
      show (a - (i + 1)).nat_abs + 1 = (a - i).nat_abs,
      zify,
      rw [← int.abs_eq_nat_abs, abs_eq_self.mpr _, ← int.abs_eq_nat_abs, abs_eq_self.mpr _],
      { ring },
      all_goals { linarith only [H₁, H₂] }, },
    have aux₂ : (complex_shape.down ℕ).prev (a - i).nat_abs = (a - (i - 1)).nat_abs,
    { apply complex_shape.prev_eq',
      show (a - i).nat_abs + 1 = (a - (i - 1)).nat_abs,
      zify,
      rw [← int.abs_eq_nat_abs, abs_eq_self.mpr _, ← int.abs_eq_nat_abs, abs_eq_self.mpr _],
      { ring },
      all_goals { linarith only [H₁, H₂] }, },
    rw [← aux₁, ← aux₂],
  end }

end category_theory.projective


/- Author: E.W.Ayers
   Skeleton category.
   This should probably live in full_subcategory.lean
   -/
import .pullbacks
import category_theory.full_subcategory

def logic.equivalence := @equivalence

namespace category_theory

universes u v

def is_thin (C : Type u) [𝒞 : category.{v} C] := ∀ {X Y : C}, subsingleton (X ⟶ Y)

section arrows
def arrows (C : Type u) [𝒞 : category.{v} C] := comma (𝟭 C) (𝟭 C)
variables {C : Type u} [𝒞 : category.{v} C] {X Y Z : C} {i : X ≅ Y}
include 𝒞

def are_iso (X Y : C) : Prop := nonempty (X ≅ Y)

lemma are_iso.refl : are_iso X X := ⟨iso.refl X⟩

lemma are_iso.symm : are_iso X Y → are_iso Y X
| ⟨i⟩ := ⟨i.symm⟩

lemma are_iso.trans : are_iso X Y → are_iso Y Z → are_iso X Z
| ⟨a⟩ ⟨b⟩ := ⟨iso.trans a b⟩

lemma are_iso.equiv : logic.equivalence (@are_iso C 𝒞) :=
⟨λ _, are_iso.refl, λ _ _, are_iso.symm, λ _ _ _, are_iso.trans⟩

instance : category (arrows C) := show category (comma _ _), by apply_instance

def crush.setoid : setoid (arrows C) :=
{ r := λ f g, nonempty (f ≅ g),
  iseqv := are_iso.equiv
}

variable (C)

def crush := @quotient (arrows C) crush.setoid

end arrows

variables {C : Type u} [𝒞 : category.{v} C] {X Y Z : C} {i : X ≅ Y}
include 𝒞

/-- A map `r` induces a skeleton category. -/
class skeleton_map (r : C → C) :=
(repr_iso : ∀ (X : C), r(X) ≅ X)
(eq_of_iso : ∀ {X Y : C}, (X ≅ Y) → r(X) = r(Y))

open skeleton_map

def skeleton (r : C → C) [@skeleton_map C 𝒞 r] : Type u := {X : C // ∃ (Y : C), r(Y) = X}

namespace skeleton
variables {r : C → C} [@skeleton_map C 𝒞 r]
instance skel_cat : category.{v} (skeleton r) := show category {X : C // _}, by apply_instance

def forget : (skeleton r) ⥤ C := full_subcategory_inclusion _

def to_skeleton : C ⥤ (skeleton r) :=
{ obj := λ X, ⟨r X,X,rfl⟩,
  map := λ X Y f, show r X ⟶ r Y, from (@repr_iso C 𝒞 r _ X).hom ≫ f ≫ (@repr_iso C 𝒞 r _ Y).inv,
  map_id' := begin intros, simp, refl end,
  map_comp' := begin
    intros, dsimp,
    refine calc (@repr_iso C 𝒞 r _ X).hom ≫ (f ≫ g) ≫ (@repr_iso C 𝒞 r _ Z).inv
                = (@repr_iso C 𝒞 r _ X).hom ≫ f ≫ ((@repr_iso C 𝒞 r _ Y).inv ≫ (@repr_iso C 𝒞 r _ Y).hom) ≫ g ≫ (@repr_iso C 𝒞 r _ Z).inv : _
            ... = ((@repr_iso C 𝒞 r _ X).hom ≫ f ≫ (@repr_iso C 𝒞 r _ Y).inv) ≫ ((@repr_iso C 𝒞 r _ Y).hom ≫ g ≫ (@repr_iso C 𝒞 r _ Z).inv) : _,
    rw [iso.inv_hom_id], simp,
    simp,
  end
}

@[simp] lemma to_skeleton_map_def {X Y : C} {f : X ⟶ Y} : @functor.map _ _ _ _ (@to_skeleton _ _ r _) X Y f = ((@repr_iso C 𝒞 r _ X).hom ≫ f ≫ (@repr_iso C 𝒞 r _ Y).inv : r X ⟶ r Y) := rfl
@[simp] lemma to_skeleton_obj_def {X : C}  : @functor.obj _ _ _ _ (@to_skeleton _ _ r _) X = ⟨r X, X, rfl⟩ := rfl
@[simp] lemma forget_map_def {X Y : skeleton r} {f : X ⟶ Y} : @functor.map _ _ _ _ (@forget _ _ r _) X Y f = f := rfl
@[simp] lemma forget_obj_def {X : skeleton r}: @functor.obj _ _ _ _ (@forget _ _ r _) X = X.val := rfl

def isequiv : C ≌ skeleton r :=
{ functor := to_skeleton,
  inverse := forget,
  unit_iso := begin refine nat_iso.of_components (λ X, (@repr_iso C 𝒞 r _ X).symm) _, intros, simp, end,
  counit_iso := begin
    refine nat_iso.of_components _ _,
    { rintro X,
      dsimp,
      let x := (@repr_iso _ 𝒞 r _ X.val),
      refine iso.mk x.hom x.inv _ _,
      simp, apply iso.hom_inv_id,
      apply iso.inv_hom_id,
    },
    intros, simp,
    show ((repr_iso r X.val).hom ≫ f ≫ (repr_iso r Y.val).inv) ≫ (repr_iso r Y.val).hom =
    (repr_iso r X.val).hom ≫ f,
    repeat {rw [category.assoc]},
    rw [iso.inv_hom_id], simp,
 end
}
/- Define a noncomputable skeleton using quotients. -/
namespace canonical

variable (C)

def q.setoid : setoid C :=
{ r := are_iso,
  iseqv := are_iso.equiv
}

local attribute [instance] q.setoid

/-- Quotient the given category on isomorphisms.
    Instead of defining this to be the category, we use this to construct a
    canonical set of representatives using choice and then define the skeleton
    as the full subcategory on these representatives. -/
def q := quotient (q.setoid C)

variable {C}

def q.mk (X : C) : q C := ⟦X⟧

noncomputable def re : C → C := quotient.out ∘ q.mk
noncomputable def re_iso (X : C) : re X ≅ X := @classical.choice _ $ @quotient.mk_out C (q.setoid C) $ X

noncomputable instance r_is_skeleton_map : @skeleton_map C 𝒞 re :=
{ repr_iso := λ X, re_iso X,
  eq_of_iso := λ X Y xy, begin have : q.mk X = q.mk Y, refine quotient.sound ⟨xy⟩, show quotient.out (q.mk X) = quotient.out (q.mk Y), rw this  end,
}

end canonical

/-- For all categories, a skeleton exists but you might need choice to get it. -/
lemma has_skeleton : ∃ (r : C → C), nonempty(@skeleton_map C 𝒞 r) := ⟨canonical.re, ⟨canonical.r_is_skeleton_map⟩⟩

end skeleton

end category_theory


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

universes v₁ u₁ l u₂ v₂ u_1 u_2

namespace Mathlib

/-!
# The category of commutative monoids in a braided monoidal category.
-/

/--
A commutative monoid object internal to a monoidal category.
-/
structure CommMon_ (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C]
extends Mon_ C
where
  mul_comm' : autoParam (category_theory.iso.hom β_ ≫ Mon_.mul _to_Mon_ = Mon_.mul _to_Mon_)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem CommMon_.mul_comm {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (c : CommMon_ C) : category_theory.iso.hom β_ ≫ Mon_.mul (CommMon_.to_Mon_ c) = Mon_.mul (CommMon_.to_Mon_ c) := sorry

@[simp] theorem CommMon_.mul_comm_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (c : CommMon_ C) {X' : C} (f' : Mon_.X (CommMon_.to_Mon_ c) ⟶ X') : category_theory.iso.hom β_ ≫ Mon_.mul (CommMon_.to_Mon_ c) ≫ f' = Mon_.mul (CommMon_.to_Mon_ c) ≫ f' := sorry

namespace CommMon_

/--
The trivial commutative monoid object. We later show this is initial in `CommMon_ C`.
-/
def trivial (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] : CommMon_ C :=
  mk (Mon_.mk (Mon_.X (Mon_.trivial C)) (Mon_.one (Mon_.trivial C)) (Mon_.mul (Mon_.trivial C)))

protected instance inhabited (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] : Inhabited (CommMon_ C) :=
  { default := trivial C }

protected instance category_theory.category {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] : category_theory.category (CommMon_ C) :=
  category_theory.induced_category.category to_Mon_

@[simp] theorem id_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (A : CommMon_ C) : Mon_.hom.hom 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] {R : CommMon_ C} {S : CommMon_ C} {T : CommMon_ C} (f : R ⟶ S) (g : S ⟶ T) : Mon_.hom.hom (f ≫ g) = Mon_.hom.hom f ≫ Mon_.hom.hom g :=
  rfl

/-- The forgetful functor from commutative monoid objects to monoid objects. -/
def forget₂_Mon_ (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] : CommMon_ C ⥤ Mon_ C :=
  category_theory.induced_functor to_Mon_

@[simp] theorem forget₂_Mon_obj_one (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (A : CommMon_ C) : Mon_.one (category_theory.functor.obj (forget₂_Mon_ C) A) = Mon_.one (to_Mon_ A) :=
  rfl

@[simp] theorem forget₂_Mon_obj_mul (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (A : CommMon_ C) : Mon_.mul (category_theory.functor.obj (forget₂_Mon_ C) A) = Mon_.mul (to_Mon_ A) :=
  rfl

@[simp] theorem forget₂_Mon_map_hom (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] {A : CommMon_ C} {B : CommMon_ C} (f : A ⟶ B) : Mon_.hom.hom (category_theory.functor.map (forget₂_Mon_ C) f) = Mon_.hom.hom f :=
  rfl

protected instance unique_hom_from_trivial {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (A : CommMon_ C) : unique (trivial C ⟶ A) :=
  Mon_.unique_hom_from_trivial (to_Mon_ A)

protected instance category_theory.limits.has_initial {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] : category_theory.limits.has_initial (CommMon_ C) :=
  category_theory.limits.has_initial_of_unique (trivial C)

end CommMon_

namespace category_theory.lax_braided_functor

/--
A lax braided functor takes commutative monoid objects to commutative monoid objects.

That is, a lax braided functor `F : C ⥤ D` induces a functor `CommMon_ C ⥤ CommMon_ D`.
-/
@[simp] theorem map_CommMon_map {C : Type u₁} [category C] [monoidal_category C] [braided_category C] {D : Type u₂} [category D] [monoidal_category D] [braided_category D] (F : lax_braided_functor C D) (A : CommMon_ C) (B : CommMon_ C) (f : A ⟶ B) : functor.map (map_CommMon F) f = functor.map (lax_monoidal_functor.map_Mon (to_lax_monoidal_functor F)) f :=
  Eq.refl (functor.map (map_CommMon F) f)

/-- `map_CommMon` is functorial in the lax braided functor. -/
def map_CommMon_functor (C : Type u₁) [category C] [monoidal_category C] [braided_category C] (D : Type u₂) [category D] [monoidal_category D] [braided_category D] : lax_braided_functor C D ⥤ CommMon_ C ⥤ CommMon_ D :=
  functor.mk map_CommMon
    fun (F G : lax_braided_functor C D) (α : F ⟶ G) =>
      nat_trans.mk
        fun (A : CommMon_ C) =>
          Mon_.hom.mk (nat_trans.app (monoidal_nat_trans.to_nat_trans α) (Mon_.X (CommMon_.to_Mon_ A)))

end category_theory.lax_braided_functor

namespace CommMon_

namespace equiv_lax_braided_functor_punit

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simp] theorem lax_braided_to_CommMon_map (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (F : category_theory.lax_braided_functor (category_theory.discrete PUnit) C) (G : category_theory.lax_braided_functor (category_theory.discrete PUnit) C) (α : F ⟶ G) : category_theory.functor.map (lax_braided_to_CommMon C) α =
  category_theory.nat_trans.app
    (category_theory.functor.map
      (category_theory.lax_braided_functor.map_CommMon_functor (category_theory.discrete PUnit) C) α)
    (trivial (category_theory.discrete PUnit)) :=
  Eq.refl (category_theory.functor.map (lax_braided_to_CommMon C) α)

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simp] theorem CommMon_to_lax_braided_obj_to_lax_monoidal_functor_to_functor_obj (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (A : CommMon_ C) (_x : category_theory.discrete PUnit) : category_theory.functor.obj
    (category_theory.lax_monoidal_functor.to_functor
      (category_theory.lax_braided_functor.to_lax_monoidal_functor
        (category_theory.functor.obj (CommMon_to_lax_braided C) A)))
    _x =
  Mon_.X (to_Mon_ A) := sorry

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simp] theorem unit_iso_hom_app_to_nat_trans_app (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (X : category_theory.lax_braided_functor (category_theory.discrete PUnit) C) : ∀ (X_1 : category_theory.discrete PUnit),
  category_theory.nat_trans.app
      (category_theory.monoidal_nat_trans.to_nat_trans
        (category_theory.nat_trans.app (category_theory.iso.hom (unit_iso C)) X))
      X_1 =
    category_theory.eq_to_hom
      (congr_arg
        (category_theory.functor.obj
          (category_theory.lax_monoidal_functor.to_functor
            (category_theory.lax_braided_functor.to_lax_monoidal_functor X)))
        (unit_iso._proof_1 X_1)) := sorry

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simp] theorem counit_iso_inv_app_hom (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] (X : CommMon_ C) : Mon_.hom.hom (category_theory.nat_trans.app (category_theory.iso.inv (counit_iso C)) X) = 𝟙 :=
  Eq.refl 𝟙

end equiv_lax_braided_functor_punit

/--
Commutative monoid objects in `C` are "just" braided lax monoidal functors from the trivial
braided monoidal category to `C`.
-/
@[simp] theorem equiv_lax_braided_functor_punit_functor (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] [category_theory.braided_category C] : category_theory.equivalence.functor (equiv_lax_braided_functor_punit C) =
  equiv_lax_braided_functor_punit.lax_braided_to_CommMon C :=
  Eq.refl (category_theory.equivalence.functor (equiv_lax_braided_functor_punit C))


import .geom3d
import tactic.linarith

def world_fr := geom3d_std_frame
def world := geom3d_std_space

def target_fr :=
 let origin := mk_position3d world 1.000000 2.000000 3.000000 in
 let basis0 := mk_displacement3d world 4.000000 3.000000 2.000000 in
 let basis1 := mk_displacement3d world 1.000000 2.000000 3.000000 in
 let basis2 := mk_displacement3d world 2.000000 1.000000 2.000000 in
 mk_geom3d_frame origin basis0 basis1 basis2

def target_sp := mk_geom3d_space target_fr

/-
Define a pose expressed over time,
in the coordinate space induced by coordinate frame target_fr
Note that target_sp, and hence, target_fr, is fixed in this definition
-/

noncomputable def target_pose : pose3d_series time_std_space target_sp
  := mk_pose3d_series_empty _ _

noncomputable def target_pose1 :=
  target_pose.update (mk_time _ 1)
  (mk_pose3d _ (mk_orientation3d _ 1 2 1 1 1 1 1 1 1) (mk_position3d _ 1 1 1))

noncomputable def target_pose2 :=
  target_pose1.update (mk_time _ 2)
  (mk_pose3d _ (mk_orientation3d _ 2 2 2 2 2 2 2 2 2) (mk_position3d _ 2 2 2))

noncomputable def target_pose3 :=
  target_pose2.update (mk_time _ 3)
  (mk_pose3d _ (mk_orientation3d _ 3 3 3 3 3 3 3 3 3) (mk_position3d _ 3 3 3))

/-
suppose target_fr, the frame underlying the coordinate system of target_pose,
varies over time

We define a frame
-/

def target_fr_series : geom3d_frame_series time_std_space :=
  time_series.mk_empty

def target_fr_series1 :=
  target_fr_series.update (mk_time _ 1) target_fr

def target_fr_series2 :=
  target_fr_series.update (mk_time _ 2) (
    let origin := mk_position3d world 1.000000 3.000000 5.000000 in
    let basis0 := mk_displacement3d world 1.000000 3.000000 5.000000 in
    let basis1 := mk_displacement3d world 1.000000 3.000000 5.000000 in
    let basis2 := mk_displacement3d world 1.000000 3.000000 5.000000 in
    mk_geom3d_frame origin basis0 basis1 basis2)

def target_fr_series3 :=
  target_fr_series.update (mk_time _ 3) (
    let origin := mk_position3d world 4.000000 4.000000 4.000000 in
    let basis0 := mk_displacement3d world 4.000000 4.000000 4.000000 in
    let basis1 := mk_displacement3d world 4.000000 4.000000 4.000000 in
    let basis2 := mk_displacement3d world 4.000000 4.000000 4.000000 in
    mk_geom3d_frame origin basis0 basis1 basis2)

/-

However, assuming the intended meaning of this is that
the frame of the pose (or coordinate system induced by the frame) varies over time,
expressed by target_fr_series,
there is nothing concrete linking the target_pose variable to the target_fr_series
variable. target_pose has a fixed coordinate system, or frame, and the target_fr
series_variable has no concrete link to the target_pose variable.

Thus, the coordinate system of target_pose is, according to our system, fixed,
which does not reflect the reality of the system we are modeling.

-/

example : target_pose3.sample (mk_time _ 1) = (inhabited.default _) := sorry

example : target_pose3.sample (mk_time _ (3)) =
  (mk_pose3d _ (mk_orientation3d _ 3 3 3 3 3 3 3 3 3) (mk_position3d _ 3 3 3))
  := sorry

noncomputable def target_pose_discrete : pose3d_discrete time_std_space target_sp
  := mk_pose3d_discrete_empty time_std_space target_sp

noncomputable def target_pose_discrete1 :=
  target_pose_discrete.update (mk_time _ 1)
  (mk_pose3d _ (mk_orientation3d _ 1 1 1 1 1 1 1 1 1) (mk_position3d _ 1 1 1))

noncomputable def target_pose_discrete2 :=
  target_pose_discrete1.update (mk_time _ 2)
  (mk_pose3d _ (mk_orientation3d _ 2 2 2 2 2 2 2 2 2) (mk_position3d _ 2 2 2))

noncomputable def target_pose_discrete3 :=
  target_pose_discrete2.update (mk_time _ 3)
  (mk_pose3d _ (mk_orientation3d _ 3 3 3 3 3 3 3 3 3) (mk_position3d _ 3 3 3))

#check target_pose_discrete3.sample (mk_time _ (-1))

example : target_pose_discrete3.sample_floor (mk_time _ 1.5) =
  (mk_pose3d _ (mk_orientation3d _ 1 1 1 1 1 1 1 1 1) (mk_position3d _ 1 1 1))
  := sorry
example : target_pose_discrete3.sample_floor (mk_time _ 3.5) =
  (mk_pose3d _ (mk_orientation3d _ 3 3 3 3 3 3 3 3 3) (mk_position3d _ 3 3 3))
  := sorry
example : target_pose_discrete3.sample_floor (mk_time _ 0.5) =
  (inhabited.default _) := sorry

example : target_pose_discrete3.sample (mk_time _ 1) =
  (mk_pose3d _ (mk_orientation3d _ 1 1 1 1 1 1 1 1 1) (mk_position3d _ 1 1 1))
  := sorry --rfl

def target_pos : position3d_discrete time_std_space geom3d_std_space :=
  mk_position3d_discrete_empty _ _

def target_pos1 :=
  --target_pos.update (mk_time _ 1) (mk_position3d _ 1 1 1)
  (target_pos : list (time time_std_space × position3d geom3d_std_space)) ++
  [((mk_time _ 1),(mk_position3d _ 1 1 1))]

def target_pos2 :=
  target_pos1.update (mk_time _ 2) (mk_position3d _ 2 2 2)

def target_pos3 :=
  target_pos2.update (mk_time _ 3) (mk_position3d _ 3 3 3)

example : (target_pos3.sample_floor (mk_time _ 1.5)).x = 1
  := sorry

#eval (target_pos3.sample_floor (mk_time _ 35)).z

#eval (target_pos3.sample (mk_time _ 1)).z

#eval target_pos3.length

--#eval

example : target_pose3.sample (mk_time _ 1) =
  (mk_pose3d _ (mk_orientation3d _ 1 1 1 1 1 1 1 1 1) (mk_position3d _ 1 1 1))
  := sorry


/-
Copyright (c) 2019 Robert A. Spencer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert A. Spencer, Markus Himmel
-/
import algebra.category.Group.preadditive
import category_theory.limits.shapes.kernels
import category_theory.linear
import category_theory.elementwise
import linear_algebra.basic
import category_theory.conj
import category_theory.preadditive.additive_functor

/-!
# The category of `R`-modules

`Module.{v} R` is the category of bundled `R`-modules with carrier in the universe `v`. We show
that it is preadditive and show that being an isomorphism, monomorphism and epimorphism is
equivalent to being a linear equivalence, an injective linear map and a surjective linear map,
respectively.

## Implementation details

To construct an object in the category of `R`-modules from a type `M` with an instance of the
`module` typeclass, write `of R M`. There is a coercion in the other direction.

Similarly, there is a coercion from morphisms in `Module R` to linear maps.

Unfortunately, Lean is not smart enough to see that, given an object `M : Module R`, the expression
`of R M`, where we coerce `M` to the carrier type, is definitionally equal to `M` itself.
This means that to go the other direction, i.e., from linear maps/equivalences to (iso)morphisms
in the category of `R`-modules, we have to take care not to inadvertently end up with an
`of R M` where `M` is already an object. Hence, given `f : M →ₗ[R] N`,
* if `M N : Module R`, simply use `f`;
* if `M : Module R` and `N` is an unbundled `R`-module, use `↿f` or `as_hom_left f`;
* if `M` is an unbundled `R`-module and `N : Module R`, use `↾f` or `as_hom_right f`;
* if `M` and `N` are unbundled `R`-modules, use `↟f` or `as_hom f`.

Similarly, given `f : M ≃ₗ[R] N`, use `to_Module_iso`, `to_Module_iso'_left`, `to_Module_iso'_right`
or `to_Module_iso'`, respectively.

The arrow notations are localized, so you may have to `open_locale Module` to use them. Note that
the notation for `as_hom_left` clashes with the notation used to promote functions between types to
morphisms in the category `Type`, so to avoid confusion, it is probably a good idea to avoid having
the locales `Module` and `category_theory.Type` open at the same time.

If you get an error when trying to apply a theorem and the `convert` tactic produces goals of the
form `M = of R M`, then you probably used an incorrect variant of `as_hom` or `to_Module_iso`.

-/

open category_theory
open category_theory.limits
open category_theory.limits.walking_parallel_pair

universes v u

variables (R : Type u) [ring R]

/-- The category of R-modules and their morphisms.

 Note that in the case of `R = ℤ`, we can not
impose here that the `ℤ`-multiplication field from the module structure is defeq to the one coming
from the `is_add_comm_group` structure (contrary to what we do for all module structures in
mathlib), which creates some difficulties down the road. -/
structure Module :=
(carrier : Type v)
[is_add_comm_group : add_comm_group carrier]
[is_module : module R carrier]

attribute [instance] Module.is_add_comm_group Module.is_module

namespace Module

instance : has_coe_to_sort (Module.{v} R) (Type v) := ⟨Module.carrier⟩

instance Module_category : category (Module.{v} R) :=
{ hom   := λ M N, M →ₗ[R] N,
  id    := λ M, 1,
  comp  := λ A B C f g, g.comp f,
  id_comp' := λ X Y f, linear_map.id_comp _,
  comp_id' := λ X Y f, linear_map.comp_id _,
  assoc' := λ W X Y Z f g h, linear_map.comp_assoc _ _ _ }

instance Module_concrete_category : concrete_category.{v} (Module.{v} R) :=
{ forget := { obj := λ R, R, map := λ R S f, (f : R → S) },
  forget_faithful := { } }

instance has_forget_to_AddCommGroup : has_forget₂ (Module R) AddCommGroup :=
{ forget₂ :=
  { obj := λ M, AddCommGroup.of M,
    map := λ M₁ M₂ f, linear_map.to_add_monoid_hom f } }

instance (M N : Module R) : linear_map_class (M ⟶ N) R M N :=
{ coe := λ f, f,
  .. linear_map.semilinear_map_class }

/-- The object in the category of R-modules associated to an R-module -/
def of (X : Type v) [add_comm_group X] [module R X] : Module R := ⟨X⟩

@[simp] lemma forget₂_obj (X : Module R) :
  (forget₂ (Module R) AddCommGroup).obj X = AddCommGroup.of X :=
rfl

@[simp] lemma forget₂_obj_Module_of (X : Type v) [add_comm_group X] [module R X] :
  (forget₂ (Module R) AddCommGroup).obj (of R X) = AddCommGroup.of X :=
rfl

@[simp] lemma forget₂_map (X Y : Module R) (f : X ⟶ Y) :
  (forget₂ (Module R) AddCommGroup).map f = linear_map.to_add_monoid_hom f :=
rfl

/-- Typecheck a `linear_map` as a morphism in `Module R`. -/
def of_hom {R : Type u} [ring R] {X Y : Type v} [add_comm_group X] [module R X] [add_comm_group Y]
  [module R Y] (f : X →ₗ[R] Y) : of R X ⟶ of R Y := f

@[simp] lemma of_hom_apply {R : Type u} [ring R]
  {X Y : Type v} [add_comm_group X] [module R X] [add_comm_group Y] [module R Y] (f : X →ₗ[R] Y)
  (x : X) : of_hom f x = f x := rfl

instance : inhabited (Module R) := ⟨of R punit⟩

instance of_unique {X : Type v} [add_comm_group X] [module R X] [i : unique X] :
  unique (of R X) := i

@[simp]
lemma coe_of (X : Type v) [add_comm_group X] [module R X] : (of R X : Type v) = X := rfl

variables {R}

/-- Forgetting to the underlying type and then building the bundled object returns the original
module. -/
@[simps]
def of_self_iso (M : Module R) : Module.of R M ≅ M :=
{ hom := 𝟙 M, inv := 𝟙 M }

lemma is_zero_of_subsingleton (M : Module R) [subsingleton M] :
  is_zero M :=
begin
  refine ⟨λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩⟩,
  { ext, have : x = 0 := subsingleton.elim _ _, rw [this, map_zero, map_zero], },
  { ext, apply subsingleton.elim }
end

instance : has_zero_object (Module.{v} R) :=
⟨⟨of R punit, is_zero_of_subsingleton _⟩⟩

variables {R} {M N U : Module.{v} R}

@[simp] lemma id_apply (m : M) : (𝟙 M : M → M) m = m := rfl

@[simp] lemma coe_comp (f : M ⟶ N) (g : N ⟶ U) :
  ((f ≫ g) : M → U) = g ∘ f := rfl

lemma comp_def (f : M ⟶ N) (g : N ⟶ U) : f ≫ g = g.comp f := rfl

end Module

variables {R}
variables {X₁ X₂ : Type v}

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom [add_comm_group X₁] [module R X₁] [add_comm_group X₂] [module R X₂] :
  (X₁ →ₗ[R] X₂) → (Module.of R X₁ ⟶ Module.of R X₂) := id

localized "notation `↟` f : 1024 := Module.as_hom f" in Module

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom_right [add_comm_group X₁] [module R X₁] {X₂ : Module.{v} R} :
  (X₁ →ₗ[R] X₂) → (Module.of R X₁ ⟶ X₂) := id

localized "notation `↾` f : 1024 := Module.as_hom_right f" in Module

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom_left {X₁ : Module.{v} R} [add_comm_group X₂] [module R X₂] :
  (X₁ →ₗ[R] X₂) → (X₁ ⟶ Module.of R X₂) := id

localized "notation `↿` f : 1024 := Module.as_hom_left f" in Module

/-- Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s. -/
@[simps]
def linear_equiv.to_Module_iso
  {g₁ : add_comm_group X₁} {g₂ : add_comm_group X₂} {m₁ : module R X₁} {m₂ : module R X₂}
  (e : X₁ ≃ₗ[R] X₂) :
  Module.of R X₁ ≅ Module.of R X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := begin ext, exact e.left_inv x, end,
  inv_hom_id' := begin ext, exact e.right_inv x, end, }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso' {M N : Module.{v} R} (i : M ≃ₗ[R] N) : M ≅ N :=
{ hom := i,
  inv := i.symm,
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso'_left {X₁ : Module.{v} R} {g₂ : add_comm_group X₂} {m₂ : module R X₂}
  (e : X₁ ≃ₗ[R] X₂) : X₁ ≅ Module.of R X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso'_right {g₁ : add_comm_group X₁} {m₁ : module R X₁}
  {X₂ : Module.{v} R} (e : X₁ ≃ₗ[R] X₂) : Module.of R X₁ ≅ X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

namespace category_theory.iso

/-- Build a `linear_equiv` from an isomorphism in the category `Module R`. -/
@[simps]
def to_linear_equiv {X Y : Module R} (i : X ≅ Y) : X ≃ₗ[R] Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_smul' := by tidy, }.

end category_theory.iso

/-- linear equivalences between `module`s are the same as (isomorphic to) isomorphisms
in `Module` -/
@[simps]
def linear_equiv_iso_Module_iso {X Y : Type u} [add_comm_group X] [add_comm_group Y] [module R X]
  [module R Y] :
  (X ≃ₗ[R] Y) ≅ (Module.of R X ≅ Module.of R Y) :=
{ hom := λ e, e.to_Module_iso,
  inv := λ i, i.to_linear_equiv, }

namespace Module

instance : preadditive (Module.{v} R) :=
{ add_comp' := λ P Q R f f' g,
    show (f + f') ≫ g = f ≫ g + f' ≫ g, by { ext, simp },
  comp_add' := λ P Q R f g g',
    show f ≫ (g + g') = f ≫ g + f ≫ g', by { ext, simp } }

instance forget₂_AddCommGroup_additive : (forget₂ (Module.{v} R) AddCommGroup).additive := {}

section
variables {S : Type u} [comm_ring S]

instance : linear S (Module.{v} S) :=
{ hom_module := λ X Y, linear_map.module,
  smul_comp' := by { intros, ext, simp },
  comp_smul' := by { intros, ext, simp }, }

variables {X Y X' Y' : Module.{v} S}

lemma iso.hom_congr_eq_arrow_congr (i : X ≅ X') (j : Y ≅ Y') (f : X ⟶ Y) :
  iso.hom_congr i j f = linear_equiv.arrow_congr i.to_linear_equiv j.to_linear_equiv f := rfl

lemma iso.conj_eq_conj (i : X ≅ X') (f : End X) :
  iso.conj i f = linear_equiv.conj i.to_linear_equiv f := rfl

end

end Module

instance (M : Type u) [add_comm_group M] [module R M] : has_coe (submodule R M) (Module R) :=
⟨ λ N, Module.of R N ⟩