import tactic.basic

-- Useful lemmas for dealing with function types
lemma ftype {α α': Type} {β β': Type}: α = α' → β = β' → (α → β) = (α' → β') :=
by { intros p q, rw [p, q] }

lemma ftype_right (α: Type) {β β': Type}: β = β' → (α → β) = (α → β') :=
by { intro p, rw [p] }

lemma fcast: ∀ {α β γ: Type} (f: α → β) (a: α) (h: (β = γ)), (cast h (f a)) = (cast (ftype_right α h) f) a :=
 by { intros α β γ f a h, finish }

 lemma fcast': ∀ {α β γ: Type} (f: α → β) (a: α) (h: (β = γ)) (h': ((α → β) = (α → γ))), (cast h (f a)) = (cast h' f) a :=
 by { intros α β γ f a h, finish }

namespace complexity

/- Complexity is defined in terms of a model of program and data.
 - The model is provided a function that checks the cost of the computing a given output
 -  another function that applies some data as an argument to the program
 - The accepts_with_cost function can only return a single result
 -
 - Data can be converted from lean types into the data type using the
 -  has_encoding class
 -/

structure model (α β γ: Type*) [has_equiv β]  [preorder γ]  [has_add γ] :=
mk ::
  (accepts_with_cost : α → β → γ → Prop)
  (application : α → β → α)
  (cost_inj: ∀ {a: α} {b₀ b₁: β} {c₀ c₁: γ}, accepts_with_cost a b₀ c₀ → accepts_with_cost a b₁ c₁ → b₀ ≈ b₁)
  (cost_mono : ∀ {a : α} {b : β} {c₀ c₁ : γ}, c₀ ≤ c₁ → accepts_with_cost a b c₀ → accepts_with_cost a b c₁)

universes u₀ u₁ u₂
variables {α: Type u₀} {β: Type u₁} {γ: Type u₂} [has_equiv β] [preorder γ] [has_add γ]

namespace model
@[simp] def program_type: model α β γ → Type u₀ := λ _, α
@[simp] def data_type: model α β γ → Type u₁ := λ _, β
@[simp] def cost_type: model α β γ → Type u₂ := λ _, γ
end model

structure encoding (m: model α β γ) (δ: Type) :=
mk ::
  (encode: δ → β)
  (encode_inj: ∀ x y: δ, encode x ≈ encode y ↔ x = y)

variables {m: model α β γ}

namespace encoding
variables {δ: Type}

@[simp] def model : encoding m δ → model α β γ := λ _,  m
@[simp] def type : encoding m δ → Type := λ _, δ

@[simp] def application (en: encoding m δ) (prog: α) (arg: δ): α :=
  en.model.application prog (en.encode arg)

@[simp] theorem inj_iff (en: encoding m δ) (a b: δ):
  en.encode a ≈ en.encode b ↔ a = b := en.encode_inj _ _
end encoding

class has_encoding (m: model α β γ) (δ: Type):= (value: encoding m δ)

def encode (m: model α β γ) {δ: Type} [f: has_encoding m δ] := f.value.encode

inductive encodable_function (m: model α β γ)
| result: Π {δ: Type}, encoding m δ → encodable_function
| application: Π {δ: Type}, encoding m δ → encodable_function → encodable_function

namespace encodable_function
@[simp] def model : encodable_function m → model α β γ := λ _, m

@[simp] def unwrap: encodable_function m → Type
| (result en) := en.type
| (application en b) := en.type → b.unwrap

@[simp] def result_type: encodable_function m → Type
| (result en) := en.type
| (application _ b) := b.result_type

def with_result (δ: Type*): encodable_function m → Type*
| (result _) := δ
| (@application _ _ _ _ _ _ _ t _ f) := t → with_result f

end encodable_function
variables {enf: encodable_function m}

structure is_encoded_function (m: model α β γ) (δ: Type):=
mk ::
  (value: encodable_function m)
  (sound: value.unwrap = δ)

class has_encodable_function (m: model α β γ) (δ: Type) := (value: is_encoded_function m δ)

variables {δ: Type} [has_encodable_function m δ]

@[simp] theorem unwrap_has_encodable (a: has_encodable_function m δ): a.value.value.unwrap = δ := a.value.sound
theorem unwrap_has_encodable' (a: has_encodable_function m δ): δ = a.value.value.unwrap := a.value.sound.symm

@[simp] theorem unwrap_is_encoded_function (a: is_encoded_function m δ): a.value.unwrap = δ := a.sound

def cast_unwrap [a: has_encodable_function m δ] (f: δ): a.value.value.unwrap :=
  cast (unwrap_has_encodable' a) f

instance encodable_result (δ: Type) [f: has_encoding m δ]:
    has_encodable_function m δ :=
  ⟨ ⟨ encodable_function.result f.value, rfl ⟩ ⟩

instance encodable_application (δ: Type) [f: has_encoding m δ] (ε: Type) [g: has_encodable_function m ε]:
    has_encodable_function m (δ → ε) :=
  ⟨ ⟨ encodable_function.application f.value g.value.value, ftype rfl g.value.sound ⟩ ⟩

def result_type (m: model α β γ) (δ: Type) [f: has_encodable_function m δ] := f.value.value.result_type

def with_result' (m: model α β γ) (δ :Type) (η: Type*) [ef: has_encodable_function m δ]: Type* :=
  encodable_function.with_result δ ef.value.value

def cost_function: encodable_function m → Type u₂
| (encodable_function.result _) := γ
| (encodable_function.application en c) := en.type → cost_function c

@[simp] def cost_function' (m: model α β γ) (δ : Type) [f: has_encodable_function m δ] := cost_function f.value.value

namespace cost_function
variables {cf₀ cf₁ : cost_function enf}

def less_than_or_equal: Π {enf: encodable_function m}, cost_function enf → cost_function enf → Prop
| (encodable_function.result _) := λ n m: γ, n ≤ m
| (encodable_function.application _ _) := λ f g, ∀ a, less_than_or_equal (f a) (g a)

instance: preorder (cost_function enf) := begin
  fconstructor,
  exact cost_function.less_than_or_equal,
  induction enf,
  { intro cf, refl },
  { intros cf x, exact enf_ih _ },
  induction enf,
  { intros a b c,
    apply preorder.le_trans},
  { intros a b c hab hac x,
    exact enf_ih _ _ _ (hab x) (hac x) },
end

def add: Π {enf: encodable_function m}, cost_function enf → cost_function enf → cost_function enf
| (encodable_function.result _) := λ n m: γ, (n + m: γ)
| (encodable_function.application _ _) := λ f g a, add (f a) (g a)

instance add_costs: has_add (cost_function enf) := ⟨ add ⟩

def lift: Π (enf: encodable_function m), γ → cost_function enf
| (encodable_function.result _) := λ c, c
| (encodable_function.application _ enf) := λ c _, lift enf c

instance lift_costs: has_lift γ (cost_function enf) := ⟨ lift enf ⟩

-- theorem add_lift
--   {φ: Type} [en: has_encoding m φ]
--   {ψ: Type} [enf: has_encodable_function m (φ → ψ)]
--   (cf: cost_function enf.) (c: γ):
-- begin
--  apply @eq (cost_function (encodable_function.application en.value enf)),
--  apply has_add.add _ _,
--  apply_instance,
--  exact (λ b, cf),
--  apply cost_function.lift begin
--   apply has_encodable_function.value.value,
--   swap,

--  end,
--  apply c,
--  refine (λ b, _),
--  apply has_add.add _ _,
--  apply_instance,
--  apply cf,
--  apply cost_function.lift,
--  apply c,
-- end
-- :=
-- begin
--   ext1,
--   simp [has_add.add, add, has_lift.lift, lift],
-- end

end cost_function

-- witness checks if the program provided is accepted by the cost function for all inputs
-- since cost_function is monotonic on the cost, this is a less than or equal relationship
def witness: Π (enf : encodable_function m), α → enf.unwrap → (cost_function enf) → Prop
| (encodable_function.result en) := λ prog data, en.model.accepts_with_cost prog (en.encode data)
| (encodable_function.application en b) := λ prog f cost, ∀ arg : en.type,
  witness b (encoding.application en prog arg) (f arg) (cost arg)

theorem witness_trans (enf: encodable_function m) {cf cg: cost_function enf}:
  ∀ {prog: α} {f: enf.unwrap}, cf ≤ cg → witness enf prog f cf → witness enf prog f cg :=
begin
  induction enf generalizing cf cg;
  intros prog f hc,
  { exact model.cost_mono m hc },
  intros hf arg,
  exact enf_ih (hc _) (hf _),
end

def witness' (m: model α β γ) {δ: Type} [enf: has_encodable_function m δ] (prog: α) (f: δ) (cf: cost_function enf.value.value) :=
  witness enf.value.value prog (cast_unwrap f) cf

def complexity_le [enf: has_encodable_function m δ] (f: δ) (cf: cost_function enf.value.value) :=
  ∃ prog: α, witness enf.value.value prog (cast_unwrap f) cf

theorem complexity_le_trans (m: model α β γ) [enf: has_encodable_function m δ] {f: δ} {cf cg: cost_function enf.value.value}:
  cf ≤ cg → complexity_le f cf → complexity_le f cg :=
begin
  intros mono hcf,
  cases hcf with prog witness,
  exact ⟨prog, witness_trans _ mono witness⟩
end

structure is_complexity (m: model α β γ) {δ: Type} [has_encodable_function m δ] (f: δ) :=
mk ::
  (cost : cost_function' m δ)
  (proof : complexity_le f cost)

class has_complexity (m: model α β γ) {δ: Type} [has_encodable_function m δ] (f: δ) :=
  (value: is_complexity m f)

theorem omega_equiv  {m: model α β γ} {δ: Type} [enf: has_encodable_function m δ] {f: δ} {cf: cost_function enf.value.value}:
  complexity_le f cf → ∀ g, f = g → complexity_le g cf :=
begin
  intros hf g hfg,
  rw [← hfg],
  exact hf,
end

end complexity

def complexity {α β γ: Type} [has_equiv β] [preorder γ] [has_add γ]
  (m: complexity.model α β γ) {δ: Type} [complexity.has_encodable_function m δ]
  (f: δ) [c: complexity.has_complexity m f]:
  complexity.cost_function' m δ := c.value.cost

instance {α β γ: Type} [has_equiv β] [preorder γ] [has_add γ] (m: complexity.model α β γ)
  (δ: Type) [complexity.has_encodable_function m δ]:
  has_le (complexity.cost_function' m δ) :=
  ⟨ complexity.cost_function.less_than_or_equal ⟩

def complexity_of_instance {α β γ: Type} [has_equiv β] [preorder γ] [has_add γ]
  (m: complexity.model α β γ) {δ: Type} [enf: complexity.has_encodable_function m δ]
  (f: δ) [c: complexity.has_complexity m f] (cf: complexity.cost_function' m δ):
  c.value.cost ≤ cf → complexity.complexity_le f cf :=
 λ mono, complexity.complexity_le_trans m mono c.value.proof


-- lemmas about sizes of syntactic elements used for termination

import .syntax .etc

-- to use values, expressions, terms, specs, histories and environments with recursion,
-- we need to show that the recursion is decreasing, i.e. its parts are smaller than the whole

lemma sizeof_value_func_R {f x: var} {R S: spec} {e: exp} {σ: env}:
      R.sizeof < (value.func f x R S e σ).sizeof :=
  begin
    unfold value.sizeof,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_value_func_S {f x: var} {R S: spec} {e: exp} {σ: env}:
      S.sizeof < (value.func f x R S e σ).sizeof :=
  begin
    unfold value.sizeof,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_value_func_e {f x: var} {R S: spec} {e: exp} {σ: env}:
      e.sizeof < (value.func f x R S e σ).sizeof :=
  begin
    unfold value.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_value_func_σ {f x: var} {R S: spec} {e: exp} {σ: env}:
      σ.sizeof < (value.func f x R S e σ).sizeof :=
  begin
    unfold value.sizeof,
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_true {x: var} {e: exp}:
      e.sizeof < (exp.true x e).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_false {x: var} {e: exp}:
      e.sizeof < (exp.false x e).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_num {x: var} {n: ℤ} {e: exp}:
      e.sizeof < (exp.num x n e).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_func_R {f x: var} {R S: spec} {e₁ e₂: exp}:
      R.sizeof < (exp.func f x R S e₁ e₂).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_func_S {f x: var} {R S: spec} {e₁ e₂: exp}:
      S.sizeof < (exp.func f x R S e₁ e₂).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_func_e₁ {f x: var} {R S: spec} {e₁ e₂: exp}:
      e₁.sizeof < (exp.func f x R S e₁ e₂).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_func_e₂ {f x: var} {R S: spec} {e₁ e₂: exp}:
      e₂.sizeof < (exp.func f x R S e₁ e₂).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_unop {x y: var} {op: unop} {e: exp}:
      e.sizeof < (exp.unop y op x e).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_binop {x y z: var} {op: binop} {e: exp}:
      e.sizeof < (exp.binop z op x y e).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_app {x y z: var} {e: exp}:
      e.sizeof < (exp.app z x y e).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_ite_e₁ {x: var} {e₁ e₂: exp}:
      e₁.sizeof < (exp.ite x e₁ e₂).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_exp_ite_e₂ {x: var} {e₁ e₂: exp}:
      e₂.sizeof < (exp.ite x e₁ e₂).sizeof :=
  begin
    unfold exp.sizeof,
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_term_value {v: value}:
      v.sizeof < (term.value v).sizeof :=
  begin
    unfold term.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end

lemma sizeof_term_unop {op: unop} {t: term}:
      t.sizeof < (term.unop op t).sizeof :=
  begin
    unfold term.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_term_binop₁ {op: binop} {t₁ t₂: term}:
      t₁.sizeof < (term.binop op t₁ t₂).sizeof :=
  begin
    unfold term.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_term_binop₂ {op: binop} {t₁ t₂: term}:
      t₂.sizeof < (term.binop op t₁ t₂).sizeof :=
  begin
    unfold term.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_term_app₁ {t₁ t₂: term}:
      t₁.sizeof < (term.app t₁ t₂).sizeof :=
  begin
    unfold term.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_term_app₂ {t₁ t₂: term}:
      t₂.sizeof < (term.app t₁ t₂).sizeof :=
  begin
    unfold term.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_term {t: term}:
      t.sizeof < (spec.term t).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end

lemma sizeof_spec_not {R: spec}:
      R.sizeof < R.not.sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end

lemma sizeof_spec_and₁ {R S: spec}:
      R.sizeof < (spec.and R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < sizeof S + 1,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_and₂ {R S: spec}:
      S.sizeof < (spec.and R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + sizeof R,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_or₁ {R S: spec}:
      R.sizeof < (spec.or R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < sizeof S + 1,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_or₂ {R S: spec}:
      S.sizeof < (spec.or R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + sizeof R,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_func_t {f: term} {x: var} {R S: spec}:
      f.sizeof < (spec.func f x R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_func_R {f: term} {x: var} {R S: spec}:
      R.sizeof < (spec.func f x R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < sizeof S + (1 + sizeof f + sizeof x),
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_spec_func_S {f: term} {x: var} {R S: spec}:
      S.sizeof < (spec.func f x R S).sizeof :=
  begin
    unfold spec.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + sizeof f + sizeof x + sizeof R,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_env_rest {σ: env} {x: var} {v: value}:
      σ.sizeof < (env.cons σ x v).sizeof :=
  begin
    unfold env.sizeof,
    rw[add_assoc],
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < sizeof x + (sizeof v + 1),
    apply lt_add_of_le_of_pos nonneg_of_nat,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_env_value {σ: env} {x: var} {v: value}:
      v.sizeof < (env.cons σ x v).sizeof :=
  begin
    unfold env.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_prop_not {P: prop}:
      P.sizeof < P.not.sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    from zero_lt_one
  end

lemma sizeof_prop_and₁ {P S: prop}:
      P.sizeof < (prop.and P S).sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < sizeof S + 1,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_prop_and₂ {P S: prop}:
      S.sizeof < (prop.and P S).sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + sizeof P,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_prop_or₁ {P S: prop}:
      P.sizeof < (prop.or P S).sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_assoc],
    rw[add_comm],
    rw[add_assoc],
    apply lt_add_of_pos_right,
    change 0 < sizeof S + 1,
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_prop_or₂ {P S: prop}:
      S.sizeof < (prop.or P S).sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    change 0 < 1 + sizeof P,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_prop_exis {P: prop} {x: var}:
      P.sizeof < (prop.exis x P).sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end

lemma sizeof_prop_forall {P: prop} {x: var}:
      P.sizeof < (prop.forallc x P).sizeof :=
  begin
    unfold prop.sizeof,
    rw[add_comm],
    apply lt_add_of_pos_right,
    rw[add_comm],
    apply lt_add_of_le_of_pos nonneg_of_nat,
    from zero_lt_one
  end


import for_mathlib.category_theory.triangulated.homological_functor

namespace category_theory

open limits category pretriangulated
open_locale zero_object

lemma ess_surj.of_iso {C D : Type*} [category C] [category D] {F G : C ⥤ D}
  (e : F ≅ G) [ess_surj F] : ess_surj G :=
⟨λ Y,  ⟨_, ⟨e.symm.app _ ≪≫ F.obj_obj_preimage_iso Y⟩⟩⟩

namespace functor

instance preserves_zero_morphisms_comp {C D E : Type*} [category C] [category D] [category E]
  [has_zero_morphisms C] [has_zero_morphisms D] [has_zero_morphisms E]
  (F : C ⥤ D) (G : D ⥤ E) [F.preserves_zero_morphisms] [G.preserves_zero_morphisms] :
  (F ⋙ G).preserves_zero_morphisms := { }

lemma preserves_zero_morphisms.of_iso {C D : Type*} [category C] [category D] {F G : C ⥤ D}
  [has_zero_morphisms C] [has_zero_morphisms D]
  (e : F ≅ G) [F.preserves_zero_morphisms] : G.preserves_zero_morphisms :=
⟨λ X Y, by rw [← cancel_epi (e.hom.app X), ← e.hom.naturality, F.map_zero, comp_zero, zero_comp]⟩

namespace is_homological

section

variables {C D A : Type*} [category C] [has_zero_object C] [has_shift C ℤ]
  [preadditive C] [∀ (n : ℤ), (shift_functor C n).additive] [pretriangulated C]
  [category D] [has_zero_object D] [has_shift D ℤ]
  [preadditive D] [∀ (n : ℤ), (shift_functor D n).additive] [pretriangulated D]
  [category A] [abelian A]

variables (L : C ⥤ D) [L.has_comm_shift ℤ]
  (hL : ∀ (T : pretriangulated.triangle D) (hT : T ∈ dist_triang D),
    ∃ (T' : pretriangulated.triangle C) (hT' : T' ∈ dist_triang C),
      nonempty (T ≅ L.map_triangle.obj T'))

lemma localization_preserves_zero_morphisms_aux (F : D ⥤ A) [ess_surj L]
  [functor.preserves_zero_morphisms L]
  (hF : (L ⋙ F).preserves_zero_morphisms) : F.preserves_zero_morphisms :=
⟨λ X Y, begin
  simp only [← cancel_epi (F.map (L.obj_obj_preimage_iso X).hom),
    ← cancel_mono (F.map (L.obj_obj_preimage_iso Y).inv), ← F.map_comp,
    zero_comp, comp_zero, ← L.map_zero, ← functor.comp_map,
    (L ⋙ F).map_zero],
end⟩

include hL

lemma ess_surj_aux : ess_surj L :=
⟨λ Y, begin
  obtain ⟨T, hT, ⟨e⟩⟩ := hL (contractible_triangle Y) (contractible_distinguished Y),
  exact ⟨_, ⟨(triangle.eval₁ D).map_iso e.symm⟩⟩,
end⟩

lemma localization_aux (F : D ⥤ A) [F.preserves_zero_morphisms]
  [L.preserves_zero_morphisms] [L.is_triangulated] (hF : (L ⋙ F).is_homological) :
  F.is_homological :=
is_homological.mk' _ (λ T hT, begin
  obtain ⟨T', hT', ⟨e⟩⟩ := hL T hT,
  exact ⟨L.map_triangle.obj T', L.map_distinguished T' hT',
    e, hF.map_distinguished T' hT'⟩,
end)

end

section

variables {C D A : Type*} [category C] [has_zero_object C] [has_shift C ℤ]
  [preadditive C] [∀ (n : ℤ), (shift_functor C n).additive] [pretriangulated C]
  [category D] [preadditive D] [has_shift D ℤ] [has_zero_object D]
  [∀ (n : ℤ), (shift_functor D n).additive] (L : C ⥤ D)
  (W : morphism_property C) [L.is_localization W] [functor.additive L]
  [W.compatible_with_shift ℤ] [left_calculus_of_fractions W]
  [right_calculus_of_fractions W] [morphism_property.compatible_with_triangulation W]
  [L.has_comm_shift ℤ]
  [category A] [abelian A]

section

variables (G : C ⥤ A) (F : (localization L W) ⥤ A)
  [preserves_zero_morphisms G] [localization.lifting L W G F]

include L W

instance : ess_surj (localization_functor L W) :=
by convert localization.ess_surj L W

instance localization_functor_preserves_zero_morphisms :
  (localization_functor L W).preserves_zero_morphisms :=
(infer_instance : L.preserves_zero_morphisms)

lemma localization_preserves_zero_morphisms' [L.preserves_zero_morphisms] :
  F.preserves_zero_morphisms :=
localization_preserves_zero_morphisms_aux (localization_functor L W) F
  (preserves_zero_morphisms.of_iso (localization.lifting.iso L W G F).symm)

lemma localization' [F.preserves_zero_morphisms] [G.is_homological] :
  F.is_homological :=
begin
  refine localization_aux (localization_functor L W) _ F _,
  { intros T hT,
    obtain ⟨T', e, hT'⟩ := hT,
    exact ⟨T', hT', ⟨e⟩⟩, },
  { let e := (localization.lifting.iso L W G F),
    exact is_homological.of_iso e, },
end

end

section

variables (G : C ⥤ A) [preserves_zero_morphisms G]
  (F : W.localization ⥤ A) [localization.lifting W.Q W G F]
  [morphism_property.stable_under_finite_products W]

include G

lemma localization_preserves_zero_morphisms : F.preserves_zero_morphisms :=
@localization_preserves_zero_morphisms' C W.localization A
    _ _ _ _ _ _ _ _ _ _ _ W.Q W _ _ _ _ _ _ _ _ _ G F _ _ _

lemma localization [F.preserves_zero_morphisms] [G.is_homological] :
  F.is_homological :=
localization' W.Q W G F

instance localization_lift_preserves_zero_morphisms [G.is_homological] (hG : W.is_inverted_by G) :
  (localization.lift G hG W.Q).preserves_zero_morphisms :=
localization_preserves_zero_morphisms W G _

instance localization_lift_is_homological [G.is_homological] (hG : W.is_inverted_by G) :
  (localization.lift G hG W.Q).is_homological :=
localization W G _

end

end

end is_homological

end functor

end category_theory


import Lbar.ext_preamble

noncomputable theory

universes u v

open opposite category_theory category_theory.limits
open_locale nnreal zero_object

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

open bounded_homotopy_category

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

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

attribute [simps] equiv.ulift add_equiv.ulift

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

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

set_option pp.universes true

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

open category_theory.preadditive

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

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

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

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

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

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

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

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

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

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

attribute [reassoc] Ext_compute_with_acyclic_naturality

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

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

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

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

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


universe variables u v

variables {α : Type u}

@[simp]
lemma coe_subtype_eq_self {x : α} {P : α → Prop}
  (h : P x)
: ↑ (⟨x, h⟩ : subtype P) = x :=
rfl

@[simp]
lemma coe_eq_subtype_val {P : α → Prop}
  (x : subtype P)
: ↑ x = x.val :=
rfl


import for_mathlib.category_theory.localization.preadditive
import category_theory.triangulated.triangulated
import for_mathlib.category_theory.localization.calculus_of_fractions
import for_mathlib.category_theory.preadditive.equivalence
import for_mathlib.category_theory.triangulated.triangulated
import for_mathlib.category_theory.functor.shift
import for_mathlib.category_theory.triangulated.triangulated_functor
import for_mathlib.category_theory.localization.triangulated_functor

noncomputable theory

namespace category_theory

open category limits pretriangulated

class morphism_property.compatible_with_shift {C : Type*} [category C]
  (W : morphism_property C) (A : Type*) [add_monoid A] [has_shift C A] : Prop :=
(translate : ∀ (a : A), W.inverse_image (shift_functor C a) = W)

lemma morphism_property.compatible_with_shift.iff {C : Type*} [category C]
  (W : morphism_property C) {A : Type*} [add_monoid A] [has_shift C A]
  [h : W.compatible_with_shift A]
  {X Y : C} (f : X ⟶ Y) (a : A) : W ((shift_functor C a).map f) ↔ W f :=
by { conv_rhs { rw ← h.translate a }, refl, }

class morphism_property.compatible_with_triangulation {C : Type*} [category C]
  [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [∀ (n : ℤ), (shift_functor C n).additive] [pretriangulated C]
  (W : morphism_property C) : Prop :=
(condition : ∀ (T₁ T₂ : triangle C) (h₁ : T₁ ∈ dist_triang C) (h₂ : T₂ ∈ dist_triang C)
  (a : T₁.obj₁ ⟶ T₂.obj₁) (b : T₁.obj₂ ⟶ T₂.obj₂) (ha : W a) (hb : W b)
  (comm : T₁.mor₁ ≫ b = a ≫ T₂.mor₁),
  ∃ (c : T₁.obj₃ ⟶ T₂.obj₃) (hc : W c),
  (T₁.mor₂ ≫ c = b ≫ T₂.mor₂) ∧ (T₁.mor₃ ≫ a⟦1⟧' = c ≫ T₂.mor₃))

namespace shift
local attribute [reducible] discrete.add_monoidal

variables {C D : Type*} [category C] [category D]
  (L : C ⥤ D) (W : morphism_property C) [L.is_localization W]
  {A : Type*} [add_monoid A] [has_shift C A] [W.compatible_with_shift A]

include L W

lemma comp_localization_inverts (a : A) : W.is_inverted_by (shift_functor C a ⋙ L) :=
λ X Y f hf,
begin
  dsimp,
  rw ← morphism_property.compatible_with_shift.iff W f a at hf,
  exact localization.inverts L W _ hf,
end

variable (A)

def localization : has_shift D A :=
begin
  let F := λ (a : A), localization.lift (shift_functor C a ⋙ L)
    (shift.comp_localization_inverts L W a) L,
  let H : Π (a : A), Comm_sq (shift_functor C a) L L (F a) :=
    λ a, ⟨localization.lifting.iso L W (shift_functor C a ⋙ L) (F a)⟩,
  let H₀ : Comm_sq (𝟭 C) L L (𝟭 D) := Comm_sq.horiz_refl L,
  let ε : 𝟭 D ≅ F 0 := localization.lift_nat_iso' H₀ (H 0) W (shift_functor_zero C A).symm,
  let μ : Π (a₁ a₂ : A), F a₁ ⋙ F a₂ ≅ F (a₁ + a₂) := λ a₁ a₂,
    localization.lifting_comp_iso (H a₁) (H a₂) (H (a₁+a₂))
      (shift_functor_add C a₁ a₂).symm W W,
  let e : Π {a₁ a₂ : A} (h : a₁ = a₂), shift_functor C a₁ ≅ shift_functor C a₂ :=
    λ a₁ a₂ h, eq_to_iso (by rw h),
  have Heq : Π {a b : A} (h : a = b) (X : C), (H a).iso.inv.app X = eq_to_hom (by rw h) ≫ (H b).iso.inv.app X ≫ eq_to_hom (by rw h),
  { intros a b h X,
    subst h,
    simp only [eq_to_hom_refl, id_comp, comp_id], },
  have associativity : ∀ (a₁ a₂ a₃ : A),
    eq_to_hom (by rw functor.assoc) ≫ (μ a₁ a₂).hom ◫ 𝟙 (F a₃) ≫ (μ (a₁ + a₂) a₃).hom ≫ eq_to_hom (congr_arg F (add_assoc a₁ a₂ a₃)) =
    𝟙 (F a₁) ◫ (μ a₂ a₃).hom ≫ (μ a₁ (a₂ + a₃)).hom,
  { intros a₁ a₂ a₃,
    dsimp only [μ],
    simp only [eq_to_hom_refl, id_comp, ← localization.lift_nat_trans'_id (H a₃) W,
      ← localization.lift_nat_trans'_id (H a₁) W, localization.lifting_comp_iso_hom,
      localization.hcomp_lift_nat_trans', localization.comp_lift_nat_trans', localization.comp_lift_nat_trans'_assoc],
    refine localization.nat_trans_ext L W _ _ (λ X, _),
    have this : (shift_functor_add C a₁ a₂).symm.hom ◫ 𝟙 (shift_functor C a₃) ≫ (shift_functor_add C (a₁ + a₂) a₃).symm.hom =
      eq_to_hom (functor.assoc _ _ _) ≫ (𝟙 (shift_functor C a₁) ◫ (shift_functor_add C a₂ a₃).symm.hom ≫ (shift_functor_add C a₁ (a₂ + a₃)).symm.hom) ≫
        eq_to_hom (by rw (add_assoc a₁ a₂ a₃)),
    { ext X,
      dsimp,
      simp only [obj_μ_app, eq_to_iso.inv, id_comp, assoc, μ_inv_hom_app, comp_id, functor.map_id, eq_to_hom_app, eq_to_hom_map], },
    simp only [nat_trans.comp_app, eq_to_hom_app, localization.lift_nat_trans'_app,
      localization.lift_nat_trans'_app, Comm_sq.horiz_comp_assoc_iso, assoc, this,
      Heq (add_assoc a₁ a₂ a₃), eq_to_hom_trans, L.map_comp, eq_to_hom_map, eq_to_hom_refl,
      eq_to_hom_trans_assoc, id_comp, comp_id], },
  have left_unitality : ∀ (a : A), ε.hom ◫ 𝟙 (F a) ≫ (μ 0 a).hom =
    eq_to_hom (by simpa only [zero_add]),
  { intro a,
    dsimp [ε, μ],
    rw ← localization.lift_nat_trans'_id (H a) W,
    erw localization.lifting_comp_iso_nat_trans_compatibility H₀ (H a) (H (0 + a)) (H 0) (H a) (H (0 + a))
      ((functor.right_unitor _) ≪≫ e (zero_add a).symm) (shift_functor_add C 0 a).symm W W
      (shift_functor_zero C A).inv (𝟙 _) (𝟙 _) begin
        ext X,
        dsimp,
        simp only [eq_to_hom_map, obj_ε_app, eq_to_iso.inv, eq_to_hom_app, id_comp, assoc,
          μ_inv_hom_app],
      end,
    simp only [localization.lifting_comp_iso_hom, localization.lift_nat_trans'_id, comp_id],
    refine localization.nat_trans_ext L W _ _ (λ X, _),
    rw [localization.lift_nat_trans'_app, eq_to_hom_app, Heq (zero_add a), iso.trans_hom,
      nat_trans.comp_app, functor.right_unitor_hom_app, eq_to_iso.hom, eq_to_hom_app],
    erw id_comp,
    simpa only [eq_to_hom_map, eq_to_hom_trans_assoc, eq_to_hom_refl, id_comp,
      Comm_sq.refl_horiz_comp_iso, iso.hom_inv_id_app_assoc], },
  have right_unitality : ∀ (a : A), 𝟙 (F a) ◫ ε.hom ≫ (μ a 0).hom =
    eq_to_hom (by simpa only [add_zero]),
  { intro a,
    dsimp only [ε, μ],
    rw ← localization.lift_nat_trans'_id (H a) W,
    rw localization.lift_nat_iso'_hom,
    erw localization.lifting_comp_iso_nat_trans_compatibility (H a) H₀ (H (a + 0)) (H a) (H 0) (H (a + 0))
      ((functor.right_unitor _) ≪≫ e (add_zero a).symm) (shift_functor_add C a 0).symm W W
      (𝟙 _) (shift_functor_zero C A).inv (𝟙 _) begin
        ext X,
        dsimp,
        simp only [ε_app_obj, eq_to_iso.inv, functor.map_id, assoc, comp_id, μ_inv_hom_app, eq_to_hom_app, id_comp,
          eq_to_hom_map],
      end,
    simp only [localization.lifting_comp_iso_hom, localization.lift_nat_trans'_id, comp_id],
    refine localization.nat_trans_ext L W _ _ (λ X, _),
    rw [localization.lift_nat_trans'_app, eq_to_hom_app, Heq (add_zero a), iso.trans_hom,
      nat_trans.comp_app, functor.right_unitor_hom_app, eq_to_iso.hom, eq_to_hom_app],
    erw id_comp,
    simpa only [eq_to_hom_map, eq_to_hom_trans_assoc, eq_to_hom_refl, id_comp,
      Comm_sq.horiz_comp_refl_iso, iso.hom_inv_id_app_assoc], },
  exact has_shift_mk D A
  { F := F,
    ε := ε,
    μ := μ,
    associativity := λ a₁ a₂ a₃ X, begin
      have h := congr_app (associativity a₁ a₂ a₃) X,
      simp only [nat_trans.comp_app, nat_trans.hcomp_app, eq_to_hom_app, eq_to_hom_refl,
        nat_trans.id_app, id_comp, functor.map_id, comp_id] at h,
      erw id_comp at h,
      exact h,
    end,
    left_unitality := λ a X, by simpa only [iso.trans_hom, nat_trans.comp_app,
      eq_to_iso.hom, eq_to_hom_app, nat_iso.hcomp, nat_trans.hcomp_id_app,
      iso.refl_hom] using congr_app (left_unitality a) X,
    right_unitality := λ a X, by simpa only [iso.trans_hom, nat_trans.comp_app,
      eq_to_iso.hom, eq_to_hom_app, nat_iso.hcomp, iso.refl_hom,
      nat_trans.id_hcomp_app] using congr_app (right_unitality a) X, },
end

omit L

instance : has_shift W.localization A := shift.localization W.Q W A

variable {A}

def localization_comm_shift (a : A) :
  shift_functor C a ⋙ W.Q ≅ W.Q ⋙ shift_functor W.localization a :=
(localization.fac _ _ _).symm

variable (A)

lemma shift_functor_zero_localization_inv_app (X : C) :
  (shift_functor_zero W.localization A).inv.app (W.Q.obj X) =
    W.Q.map ((shift_functor_zero C A).inv.app X) ≫ (localization_comm_shift W (0 : A)).hom.app X :=
begin
  dsimp [shift_monoidal_functor],
  simp only [localization.lift_nat_trans'_app, Comm_sq.horiz_refl_iso, iso.refl_hom,
    nat_trans.id_app],
  erw id_comp,
  refl,
end

lemma shift_functor_zero_localization_hom_app (X : C) :
  (shift_functor_zero W.localization A).hom.app (W.Q.obj X) =
    (localization_comm_shift W (0 : A)).inv.app X ≫
    W.Q.map ((shift_functor_zero C A).hom.app X) :=
begin
  rw [← cancel_mono ((shift_functor_zero W.localization A).inv.app (W.Q.obj X)),
    iso.hom_inv_id_app, shift_functor_zero_localization_inv_app, assoc, ← W.Q.map_comp_assoc,
    iso.hom_inv_id_app, W.Q.map_id, id_comp, iso.inv_hom_id_app],
  refl,
end

variable {A}

lemma shift_functor_add_localization_inv_app (a b : A) (X : C) :
  (shift_functor_add W.localization a b).inv.app (W.Q.obj X) =
    ((localization_comm_shift W a).inv.app X)⟦b⟧' ≫ (localization_comm_shift W b).inv.app (X⟦a⟧) ≫ W.Q.map ((shift_functor_add C a b).inv.app X) ≫
        (localization_comm_shift W (a+b)).hom.app X :=
begin
  dsimp [shift_monoidal_functor, localization.lifting_comp_iso, localization.lifting.uniq],
  erw localization.lift_nat_trans_app,
  simpa only [iso.symm_symm_eq, iso.trans_hom, iso_whisker_right_hom, monoidal_functor.μ_iso_hom,
    nat_trans.comp_app, Comm_sq.horiz_comp_iso_hom_app, whisker_right_app, assoc,
    nat_trans.id_app, id_comp],
end

lemma shift_functor_add_localization_hom_app (a b : A) (X : C) :
  (shift_functor_add W.localization a b).hom.app (W.Q.obj X) =
        (localization_comm_shift W (a+b)).inv.app X ≫
     W.Q.map ((shift_functor_add C a b).hom.app X) ≫
     (localization_comm_shift W b).hom.app (X⟦a⟧) ≫
    ((localization_comm_shift W a).hom.app X)⟦b⟧' :=
begin
  rw [← cancel_mono ((shift_functor_add W.localization a b).inv.app (W.Q.obj X)), assoc, assoc,
    assoc, iso.hom_inv_id_app, shift_functor_add_localization_inv_app, ← functor.map_comp_assoc,
    iso.hom_inv_id_app],
  erw [category_theory.functor.map_id, id_comp, iso.hom_inv_id_app_assoc, ← W.Q.map_comp_assoc,
    iso.hom_inv_id_app, W.Q.map_id, id_comp, iso.inv_hom_id_app],
  refl,
end

namespace has_comm_shift_localization

variable {A}

instance : functor.has_comm_shift W.Q A :=
{ iso := localization_comm_shift W,
  iso_zero := begin
    ext1,
    apply nat_trans.ext,
    ext1 X,
    dsimp [functor.comm_shift.unit, compatibility.comm_shift.unit],
    erw [id_comp, id_comp],
    change _ = W.Q.map ((shift_functor_zero C A).hom.app X) ≫
      (shift_functor_zero W.localization A).inv.app (W.Q.obj X),
    rw [shift_functor_zero_localization_inv_app, ← W.Q.map_comp_assoc, iso.hom_inv_id_app,
      W.Q.map_id, id_comp],
  end,
  iso_add := λ a b, begin
    ext1,
    apply nat_trans.ext,
    ext1 X,
    dsimp [functor.comm_shift.add, compatibility.comm_shift.comp],
    erw [id_comp, id_comp, id_comp],
    change _ = W.Q.map ((shift_functor_add C a b).hom.app X) ≫
      (localization_comm_shift W b).hom.app (X⟦a⟧) ≫
      ((localization_comm_shift W a).hom.app X)⟦b⟧' ≫
      (shift_functor_add W.localization a b).inv.app (W.Q.obj X),
    erw [shift_functor_add_localization_inv_app, ← functor.map_comp_assoc, iso.hom_inv_id_app,
      category_theory.functor.map_id, id_comp, iso.hom_inv_id_app_assoc, ← W.Q.map_comp_assoc,
      iso.hom_inv_id_app, W.Q.map_id, id_comp],
  end, }

end has_comm_shift_localization

end shift

namespace pretriangulated

variables {C D : Type*} [category C] [category D]
  [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [has_zero_object D] [has_shift D ℤ] [preadditive D]
  [∀ n : ℤ, functor.additive (shift_functor C n)] [hC : pretriangulated C]
  [∀ n : ℤ, functor.additive (shift_functor D n)]
  (L : C ⥤ D) (W : morphism_property C) [L.is_localization W]
  [W.compatible_with_shift ℤ] [functor.additive L]
  [L.has_comm_shift ℤ]
  [left_calculus_of_fractions W] [right_calculus_of_fractions W]
  [hW₆ : W.compatible_with_triangulation]

include L

namespace localization

include hC
@[simp]
def distinguished_triangles : set (triangle D) :=
λ T, ∃ (T' : triangle C) (e : T ≅ L.map_triangle.obj T'), T' ∈ dist_triang C

lemma isomorphic_distinguished {T₁ T₂ : triangle D} (e : T₂ ≅ T₁)
  (h : T₁ ∈ distinguished_triangles L) : T₂ ∈ distinguished_triangles L :=
by { rcases h with ⟨T', e', hT'⟩, exact ⟨T', e ≪≫ e',  hT'⟩, }

include W

lemma contractible_distinguished (X : D) : contractible_triangle X ∈ distinguished_triangles L :=
begin
  haveI := localization.ess_surj L W,
  let e := ((contractible_triangle_functor D).map_iso
    (L.obj_obj_preimage_iso X)),
  refine ⟨contractible_triangle (L.obj_preimage X), _, contractible_distinguished _⟩,
  { refine e.symm ≪≫ triangle.mk_iso _ _ (iso.refl _) (iso.refl _) L.map_zero_object.symm _ _ _,
    tidy, },
end

lemma rotate_distinguished_triangle (T : triangle D) :
  T ∈ distinguished_triangles L ↔ T.rotate ∈ distinguished_triangles L :=
begin
  split,
  { intro h,
    rcases h with ⟨T', e', hT'⟩,
    refine ⟨T'.rotate, (rotate D).map_iso e' ≪≫
      (L.map_triangle_rotate.app T'),
      pretriangulated.rot_of_dist_triangle C T' hT'⟩, },
  { intro h,
    rcases h with ⟨T', e', hT'⟩,
    refine ⟨T'.inv_rotate, ((triangle_rotation D).unit_iso.app T) ≪≫
        (inv_rotate D).map_iso e' ≪≫ L.map_triangle_inv_rotate.app T' ,
      pretriangulated.inv_rot_of_dist_triangle C T' hT'⟩, },
end

lemma distinguished_cocone_triangle {X Y : D} (f : X ⟶ Y) :
  ∃ (Z : D) (g : Y ⟶ Z) (h : Z ⟶ (shift_functor D (1 : ℤ)).obj X),
    triangle.mk f g h ∈ localization.distinguished_triangles L :=
begin
  let f' := left_calculus_of_fractions.lift_map L W f,
  rcases pretriangulated.distinguished_cocone_triangle _ _ f' with ⟨Z, g, h, H⟩,
  refine ⟨L.obj Z, (left_calculus_of_fractions.lift_map_iso₂ L W f).hom ≫ L.map g,
    L.map h ≫ (L.comm_shift_iso 1).hom.app _ ≫ (shift_functor D (1 : ℤ)).map
      (left_calculus_of_fractions.lift_map_iso₁ L W f).inv, triangle.mk f' g h, _, H⟩,
  dsimp,
  refine triangle.mk_iso _ _ (left_calculus_of_fractions.lift_map_iso₁ L W f)
    (left_calculus_of_fractions.lift_map_iso₂ L W f) (iso.refl _)
      (left_calculus_of_fractions.lift_map_fac L W f) (comp_id _) _,
  dsimp,
  rw [assoc, assoc, id_comp, ← functor.map_comp, iso.inv_hom_id, functor.map_id, comp_id],
end

include hW₆

lemma complete_distinguished_triangle_morphism (T₁ T₂ : triangle D)
  (hT₁ : T₁ ∈ distinguished_triangles L)
  (hT₂ : T₂ ∈ distinguished_triangles L)
  (a : T₁.obj₁ ⟶ T₂.obj₁) (b : T₁.obj₂ ⟶ T₂.obj₂) (fac : T₁.mor₁ ≫ b = a ≫ T₂.mor₁) :
  ∃ (c : T₁.obj₃ ⟶ T₂.obj₃), T₁.mor₂ ≫ c = b ≫ T₂.mor₂ ∧ T₁.mor₃ ≫ (shift_functor D 1).map a = c ≫ T₂.mor₃ :=
begin
  suffices : ∀ (T'₁ T'₂ : triangle C) (h₁ : T'₁ ∈ dist_triang C) (h₂ : T'₂ ∈ dist_triang C)
    (a : L.obj (T'₁.obj₁) ⟶ L.obj (T'₂.obj₁)) (b : L.obj (T'₁.obj₂) ⟶ L.obj (T'₂.obj₂))
    (fac : L.map T'₁.mor₁ ≫ b = a ≫ L.map T'₂.mor₁),
    ∃ (c : L.obj T'₁.obj₃ ⟶ L.obj T'₂.obj₃), L.map T'₁.mor₂ ≫ c = b ≫ L.map T'₂.mor₂ ∧
      L.map T'₁.mor₃ ≫ (L.comm_shift_iso 1).hom.app _ ≫ (shift_functor D (1 : ℤ)).map a ≫
        (L.comm_shift_iso 1).inv.app _
        = c ≫ L.map T'₂.mor₃,
  { rcases hT₁ with ⟨T'₁, e₁, hT'₁⟩,
    rcases hT₂ with ⟨T'₂, e₂, hT'₂⟩,
    have comm₁ := e₁.inv.comm₁,
    have comm₂ := e₂.hom.comm₁,
    have comm₃ := e₁.hom.comm₂,
    have comm₄ := e₂.hom.comm₂,
    have comm₅ := e₂.inv.comm₃,
    have comm₆ := e₁.hom.comm₃,
    dsimp at comm₁ comm₂ comm₃ comm₄ comm₅ comm₆,
    rcases this T'₁ T'₂ hT'₁ hT'₂ (e₁.inv.hom₁ ≫ a ≫ e₂.hom.hom₁)
      (e₁.inv.hom₂ ≫ b ≫ e₂.hom.hom₂) (by rw [reassoc_of comm₁, reassoc_of fac, assoc, assoc, comm₂])
      with ⟨c, ⟨hc₁, hc₂⟩⟩,
    refine ⟨e₁.hom.hom₃ ≫ c ≫ e₂.inv.hom₃, ⟨_, _⟩⟩,
    { simp only [reassoc_of comm₃, reassoc_of hc₁, ← reassoc_of comm₄,
        triangle.hom_inv_id_hom₃, comp_id, triangle.hom_inv_id_hom₂_assoc], },
    { simp only [assoc, ← comm₅, ← reassoc_of hc₂, (L.comm_shift_iso (1 : ℤ)).inv_hom_id_app_assoc,
      ← functor.map_comp, triangle.hom_inv_id_hom₁, comp_id, ← reassoc_of comm₆,
      triangle.hom_inv_id_hom₁_assoc], }, },
  clear fac a b hT₁ hT₂ T₁ T₂,
  intros T'₁ T'₂ hT'₁ hT'₂ a b fac,
  rcases left_calculus_of_fractions.L_map_fac L W a with ⟨za, hza⟩,
  rcases left_calculus_of_fractions.ex za.s za.hs T'₂.mor₁ with ⟨sq⟩,
  rcases left_calculus_of_fractions.L_map_fac L W (b ≫ L.map sq.s') with ⟨zb, hzb⟩,
  simp only [left_calculus_of_fractions.map_roof] at hza hzb,
  have hsq := L.congr_map sq.fac,
  simp only [L.map_comp] at hsq,
  haveI := localization.inverts L W zb.s zb.hs,
  rcases (left_calculus_of_fractions.L_map_eq_iff L W (za.f ≫ sq.g ≫ zb.s) (T'₁.mor₁ ≫ zb.f)).mp
    (by simp only [← cancel_mono (inv (L.map zb.s)), assoc, L.map_comp, ← hzb,
        is_iso.hom_inv_id, comp_id, reassoc_of fac, hsq, reassoc_of hza,
        is_iso.inv_hom_id_assoc]) with ⟨Y₃, s, hs, fac'⟩,
  simp only [assoc] at fac',
  rcases pretriangulated.distinguished_cocone_triangle _ _ (sq.g ≫ zb.s ≫ s)
    with ⟨Z₃, g₃, h₃, H₃⟩,
  let T'₃ := triangle.mk (sq.g ≫ zb.s ≫ s) g₃ h₃,
  have comm : T'₂.mor₁ ≫ sq.s' ≫ zb.s ≫ s = za.s ≫ sq.g ≫ zb.s ≫ s,
  { dsimp, rw ← reassoc_of sq.fac, },
  have h₂ : W (sq.s' ≫ zb.s ≫ s) := left_calculus_of_fractions.comp _ _ _ sq.hs'
    (left_calculus_of_fractions.comp _ _ _ zb.hs hs),
  rcases morphism_property.compatible_with_triangulation.condition T'₂ T'₃ hT'₂ H₃
    za.s (sq.s' ≫ zb.s ≫ s) za.hs h₂ comm with ⟨α, hα₀, ⟨hα₁, hα₂⟩⟩,
  let φ : T'₂ ⟶ T'₃ := triangle_morphism.mk za.s (sq.s' ≫ zb.s ≫ s) α comm hα₁ hα₂,
  haveI := localization.inverts L W _ za.hs,
  haveI := localization.inverts L W _ h₂,
  haveI := localization.inverts L W _ hα₀,
  rcases pretriangulated.complete_distinguished_triangle_morphism T'₁ T'₃ hT'₁ H₃ za.f
    (zb.f ≫ s) fac'.symm with ⟨c, ⟨hc₁, hc₂⟩⟩,
  refine ⟨L.map c ≫ inv (L.map α), ⟨_, _⟩⟩,
  { simp only [← cancel_mono (L.map α), assoc, is_iso.inv_hom_id, comp_id, ← L.map_comp, hα₁, hc₁],
    simp only [L.map_comp, reassoc_of hzb, is_iso.inv_hom_id_assoc], },
  { simp only [hza, functor.map_comp, assoc],
    erw ← (L.comm_shift_iso (1 : ℤ)).hom.naturality_assoc,
    dsimp,
    simp only [← L.map_comp_assoc, hc₂, assoc,
      ← cancel_mono ((L.comm_shift_iso (1 : ℤ)).hom.app T'₂.obj₁), iso.inv_hom_id_app_assoc,
      ← cancel_mono ((shift_functor D (1 : ℤ)).map (L.map za.s))],
    simp only [← functor.map_comp, is_iso.inv_hom_id, functor.map_id, comp_id],
    erw ← (L.comm_shift_iso (1 : ℤ)).hom.naturality,
    erw ← L.map_comp_assoc,
    simp only [hα₂, L.map_comp, assoc, is_iso.inv_hom_id_assoc], },
end

end localization

include hW₆

@[derive category, derive preadditive, derive has_zero_object]
def localization := D

instance : has_shift (localization L W) ℤ := (infer_instance : has_shift D ℤ)

instance (n : ℤ) : functor.additive (shift_functor (localization L W) n) :=
by { dsimp [localization], apply_instance, }

instance : pretriangulated (localization L W) :=
{ distinguished_triangles := localization.distinguished_triangles L,
  isomorphic_distinguished := λ T₁ hT₁ T₂ e,
    localization.isomorphic_distinguished L e hT₁,
  contractible_distinguished := localization.contractible_distinguished L W,
  distinguished_cocone_triangle := λ X Y f, localization.distinguished_cocone_triangle L W f,
  rotate_distinguished_triangle := localization.rotate_distinguished_triangle L W,
  complete_distinguished_triangle_morphism :=
    localization.complete_distinguished_triangle_morphism L W, }

instance [is_triangulated C] : is_triangulated (localization L W) :=
is_triangulated.mk'
(λ X₁' X₂' X₃' u₁₂' u₂₃', begin
  haveI := localization.ess_surj L W,
  let Y₁' := L.obj_preimage X₁',
  let X₂ := L.obj_preimage X₂',
  let Y₃' := L.obj_preimage X₃',
  let e₁ : L.obj Y₁' ≅ X₁' := functor.obj_obj_preimage_iso L X₁',
  let e₂ : L.obj X₂ ≅ X₂' := functor.obj_obj_preimage_iso L X₂',
  let e₃ : L.obj Y₃' ≅ X₃' := functor.obj_obj_preimage_iso L X₃',
  let y₁₂' : L.obj Y₁' ⟶ L.obj X₂ := e₁.hom ≫ u₁₂' ≫ e₂.inv,
  let y₂₃' : L.obj X₂ ⟶ L.obj Y₃' := e₂.hom ≫ u₂₃' ≫ e₃.inv,
  obtain ⟨⟨X₁, s₁, u₁₂, hs₁⟩, hz₁⟩ := right_calculus_of_fractions.L_map_fac L W y₁₂',
  obtain ⟨⟨X₃, u₂₃, s₂, hs₂⟩, hz₂⟩ := left_calculus_of_fractions.L_map_fac L W y₂₃',
  haveI := localization.inverts L W _ hs₁,
  haveI := localization.inverts L W _ hs₂,
  dsimp [right_calculus_of_fractions.map_roof] at hz₁,
  dsimp [left_calculus_of_fractions.map_roof] at hz₂,
  obtain ⟨Z₁₂, v₁₂, w₁₂, h₁₂⟩ := pretriangulated.distinguished_cocone_triangle _ _ u₁₂,
  obtain ⟨Z₂₃, v₂₃, w₂₃, h₂₃⟩ := pretriangulated.distinguished_cocone_triangle _ _ u₂₃,
  obtain ⟨Z₁₃, v₁₃, w₁₃, h₁₃⟩ := pretriangulated.distinguished_cocone_triangle _ _ (u₁₂ ≫ u₂₃),
  let H := (is_triangulated.octahedron_axiom rfl h₁₂ h₂₃ h₁₃).some,
  refine ⟨L.obj X₁, L.obj X₂, L.obj X₃, L.obj Z₁₂, L.obj Z₂₃, L.obj Z₁₃,
    L.map u₁₂, L.map u₂₃, e₁.symm ≪≫ (as_iso (L.map s₁)).symm, e₂.symm,
    e₃.symm ≪≫ (as_iso (L.map s₂)), _, _, _, _, ⟨_, by refl, h₁₂⟩,
    _, _, ⟨_, by refl, h₂₃⟩,
    L.map v₁₃, L.map w₁₃ ≫ (L.comm_shift_iso 1).hom.app X₁,
      ⟨_, _, h₁₃⟩, _⟩,
  { dsimp,
    rw [assoc, ← hz₁, e₁.inv_hom_id_assoc], },
  { dsimp,
    rw [← cancel_mono (inv (L.map s₂)), assoc, assoc, assoc, is_iso.hom_inv_id, comp_id, ← hz₂,
      e₂.inv_hom_id_assoc], },
  { refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) _ _ _,
    { dsimp, simp only [comp_id, functor.map_comp, id_comp], },
    { dsimp, simp only [comp_id, id_comp], },
    { dsimp, simp only [functor.map_id, comp_id, id_comp], }, },
  have comm₁₂ := congr_arg (λ (f : _ ⟶ _), L.map f) H.triangle_morphism₁.comm₂,
  have comm₁₃ := congr_arg (λ (f : _ ⟶ _), L.map f) H.triangle_morphism₁.comm₃,
  have comm₂₂ := congr_arg (λ (f : _ ⟶ _), L.map f) H.triangle_morphism₂.comm₂,
  have comm₂₃ := congr_arg (λ (f : _ ⟶ _), L.map f) H.triangle_morphism₂.comm₃,
  dsimp at comm₁₂ comm₁₃ comm₂₂ comm₂₃,
  simp only [L.map_comp, functor.map_id, id_comp, comp_id] at comm₁₂ comm₁₃ comm₂₂ comm₂₃,
  refine ⟨⟨L.map H.m₁, L.map H.m₃, comm₁₂, _, comm₂₂, _, _⟩⟩,
  { dsimp,
    rw reassoc_of comm₁₃, },
  { dsimp,
    rw [← reassoc_of comm₂₃, assoc],
    erw ← nat_trans.naturality,
    refl, },
  refine ⟨_, _, H.mem⟩,
  refine triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) _ _ _,
  { dsimp, simp only [comp_id, id_comp], },
  { dsimp, simp only [comp_id, id_comp], },
  { dsimp, simp only [assoc, functor.map_id, comp_id, functor.map_comp, id_comp],
    erw ← nat_trans.naturality, refl, },
end)

include W

def localization_functor : C ⥤ localization L W := L

instance localization_functor_has_comm_shift :
  (localization_functor L W).has_comm_shift ℤ :=
(infer_instance : L.has_comm_shift ℤ)

instance localization_functor_is_triangulated :
  (localization_functor L W).is_triangulated :=
⟨λ T hT, ⟨T, iso.refl _, hT⟩⟩

instance localization_functor_ess_surj_on_dist_triang :
  (localization_functor L W).ess_surj_on_dist_triang :=
⟨by { rintro T ⟨T', e, hT'⟩, exact ⟨T', hT', ⟨e.symm⟩⟩, }⟩

variables [morphism_property.stable_under_finite_products W] [has_finite_products C]

omit L
include hC

instance additive_shift_localization (n : ℤ) :
  functor.additive (shift_functor W.localization n) := infer_instance

--instance W_Q_has_comm_shift : W.Q.has_comm_shift ℤ := infer_instance

instance localization_pretriangulated : pretriangulated W.localization :=
(infer_instance : pretriangulated (localization W.Q W))

instance localization_triangulated [is_triangulated C] : is_triangulated W.localization :=
(infer_instance : is_triangulated (localization W.Q W))

instance Q_ess_surj_on_dist_triang :
  W.Q.ess_surj_on_dist_triang :=
(infer_instance : (localization_functor W.Q W).ess_surj_on_dist_triang)

end pretriangulated

end category_theory


import algebra.camera.option

universe u

lemma prod.mk_is_nonexpansive (α β : Type u) [ofe α] [ofe β] :
  is_nonexpansive (function.uncurry prod.mk : α × β → α × β) :=
is_nonexpansive_id

private lemma prod.camera.mul_is_nonexpansive {α β : Type u} [camera α] [camera β] :
  is_nonexpansive (function.uncurry ((*) : α × β → α × β → α × β)) :=
begin
  rintros n ⟨⟨a₁, b₁⟩, ⟨a₂, b₂⟩⟩ ⟨⟨c₁, c₂⟩, ⟨d₁, d₂⟩⟩ ⟨⟨h₁, h₂⟩, ⟨h₃, h₄⟩⟩,
  simp only [function.uncurry_apply_pair, prod.mk_mul_mk, prod.eq_at] at *,
  split,
  exact camera.mul_eq_at h₁ h₃,
  exact camera.mul_eq_at h₂ h₄,
end

@[simp] lemma prod_mk_seq_some {α β : Type u} (a : option α) (b : option β) (c : α × β) :
  prod.mk <$> a <*> b = some c ↔ a = some c.1 ∧ b = some c.2 :=
begin
  cases a,
  tauto,
  cases b,
  tauto,
  simp only [option.map_eq_map, option.map_some', option.seq_some],
  exact prod.ext_iff,
end

@[simp] lemma prod_mk_seq_none {α β : Type u} (a : option α) (b : option β) :
  prod.mk <$> a <*> b = none ↔ a = none ∨ b = none :=
by cases a; cases b; tauto

@[simp] lemma prod_mk_seq_none_left {α β : Type u} (b : option β) :
  prod.mk <$> (none : option α) <*> b = none := rfl

@[simp] lemma prod_mk_seq_none_right {α β : Type u} (a : option α) :
  prod.mk <$> a <*> (none : option β) = none := by cases a; refl

private lemma prod.camera.core_mul_self {α β : Type u} [camera α] [camera β]
  (a : α × β) {ca : α × β} : prod.mk <$> core a.1 <*> core a.2 = some ca →
    ca * a = a :=
begin
  obtain ⟨a, b⟩ := a,
  obtain ⟨ca, cb⟩ := ca,
  intro hc,
  rw prod_mk_seq_some at hc,
  ext1,
  exact camera.core_mul_self a hc.1,
  exact camera.core_mul_self b hc.2,
end

private lemma prod.camera.core_core {α β : Type u} [camera α] [camera β]
  (a : α × β) {ca : α × β} : prod.mk <$> core a.1 <*> core a.2 = some ca →
    prod.mk <$> core ca.1 <*> core ca.2 = some ca :=
begin
  obtain ⟨a, b⟩ := a,
  obtain ⟨ca, cb⟩ := ca,
  intro hc,
  rw prod_mk_seq_some at hc ⊢,
  exact ⟨camera.core_core a hc.1, camera.core_core b hc.2⟩,
end

private lemma prod.camera.core_mono_some {α β : Type u} [camera α] [camera β]
  (a b : α × β) {ca : α × β} : prod.mk <$> core a.1 <*> core a.2 = some ca → a ≼ b →
    ∃ cb : α × β, prod.mk <$> core b.1 <*> core b.2 = some cb :=
begin
  obtain ⟨a₁, a₂⟩ := a,
  obtain ⟨b₁, b₂⟩ := b,
  obtain ⟨c₁, c₂⟩ := ca,
  rintros hc ⟨⟨d₁, d₂⟩, hd⟩,
  simp only [prod.mk_mul_mk, prod.mk.inj_iff] at hd,
  rw prod_mk_seq_some at hc,
  obtain ⟨e₁, he₁⟩ := camera.core_mono_some a₁ b₁ hc.1 ⟨d₁, hd.1⟩,
  obtain ⟨e₂, he₂⟩ := camera.core_mono_some a₂ b₂ hc.2 ⟨d₂, hd.2⟩,
  refine ⟨⟨e₁, e₂⟩, _⟩,
  rw prod_mk_seq_some,
  exact ⟨he₁, he₂⟩,
end

private lemma prod.camera.core_mono {α β : Type u} [camera α] [camera β]
  (a b : α × β) {ca : α × β} : prod.mk <$> core a.1 <*> core a.2 = some ca →
    a ≼ b → prod.mk <$> core a.1 <*> core a.2 ≼ prod.mk <$> core b.1 <*> core b.2 :=
begin
  obtain ⟨a₁, a₂⟩ := a,
  obtain ⟨b₁, b₂⟩ := b,
  obtain ⟨c₁, c₂⟩ := ca,
  rintros hc ⟨⟨d₁, d₂⟩, hd⟩,
  rw prod_mk_seq_some at hc,
  simp only [prod.mk_mul_mk, prod.mk.inj_iff] at hd,
  obtain ⟨e₁, he₁⟩ := camera.core_mono a₁ b₁ hc.1 ⟨d₁, hd.1⟩,
  obtain ⟨e₂, he₂⟩ := camera.core_mono a₂ b₂ hc.2 ⟨d₂, hd.2⟩,
  rw [← he₁, ← he₂],
  cases core a₁ with ca₁; cases core a₂ with ca₂,
  { rw prod_mk_seq_none_left, exact none_incl _, },
  { rw prod_mk_seq_none_left, exact none_incl _, },
  { rw prod_mk_seq_none_right, exact none_incl _, },
  simp only [option.map_some, option.seq_some],
  cases e₁; cases e₂,
  { rw [mul_none, mul_none, option.map_some, option.seq_some],
    exact ⟨none, rfl⟩, },
  { rw [mul_none, some_mul_some, option.map_some, option.seq_some],
    refine ⟨some (ca₁, e₂), _⟩,
    rw [some_mul_some, option.some_inj],
    ext1, swap, refl,
    rw mul_none at he₁,
    change ca₁ * ca₁ = ca₁,
    rw [← option.some_inj, ← some_mul_some, he₁, camera.core_mul_core], },
  { rw [mul_none, some_mul_some, option.map_some, option.seq_some],
    refine ⟨some (e₁, ca₂), _⟩,
    rw [some_mul_some, option.some_inj],
    ext1, refl,
    rw mul_none at he₂,
    change ca₂ * ca₂ = ca₂,
    rw [← option.some_inj, ← some_mul_some, he₂, camera.core_mul_core], },
  { rw [some_mul_some, some_mul_some, option.map_some, option.seq_some],
    refine ⟨some (e₁, e₂), rfl⟩, },
end

private lemma prod.camera.validn_mul {α β : Type u} [camera α] [camera β] (a b : α × β) :
  camera.validn (a * b).1 ⊓ camera.validn (a * b).2 ≤ camera.validn a.1 ⊓ camera.validn a.2 :=
begin
  rintros n ⟨ha, hb⟩,
  exact ⟨camera.validn_mul _ _ n ha, camera.validn_mul _ _ n hb⟩,
end

private lemma prod.camera.extend_mul_eq {α β : Type u} [camera α] [camera β] (n : ℕ)
  (a b₁ b₂ : α × β) (ha : ✓[n] a.1 ∧ ✓[n] a.2) (hb : a =[n] b₁ * b₂) :
  a = ((extend ha.1 hb.1).1, (extend ha.2 hb.2).1) * ((extend ha.1 hb.1).2, (extend ha.2 hb.2).2) :=
begin
  ext1,
  exact camera.extend_mul_eq ha.1 hb.1,
  exact camera.extend_mul_eq ha.2 hb.2,
end

private lemma prod.camera.extend_eq_at_left {α β : Type u} [camera α] [camera β] (n : ℕ)
  (a b₁ b₂ : α × β) (ha : ✓[n] a.1 ∧ ✓[n] a.2) (hb : a =[n] b₁ * b₂) :
  ((extend ha.1 hb.1).1, (extend ha.2 hb.2).1) =[n] b₁ :=
begin
  split,
  exact camera.extend_eq_at_left ha.1 hb.1,
  exact camera.extend_eq_at_left ha.2 hb.2,
end

private lemma prod.camera.extend_eq_at_right {α β : Type u} [camera α] [camera β] (n : ℕ)
  (a b₁ b₂ : α × β) (ha : ✓[n] a.1 ∧ ✓[n] a.2) (hb : a =[n] b₁ * b₂) :
  ((extend ha.1 hb.1).2, (extend ha.2 hb.2).2) =[n] b₂ :=
begin
  split,
  exact camera.extend_eq_at_right ha.1 hb.1,
  exact camera.extend_eq_at_right ha.2 hb.2,
end

instance prod.camera {α β : Type u} [camera α] [camera β] : camera (α × β) := {
  validn := ⟨λ a, camera.validn a.1 ⊓ camera.validn a.2, begin
    rintros n ⟨x₁, y₁⟩ ⟨x₂, y₂⟩ ⟨hx, hy⟩,
    refine sprop.inf_eq_at _ _,
    exact nonexpansive camera.validn hx,
    exact nonexpansive camera.validn hy,
  end⟩,
  core := ⟨λ a, prod.mk <$> (core a.1) <*> (core a.2), begin
    rintros n ⟨a, b⟩ ⟨c, d⟩ ⟨hac, hbd⟩,
    refine option.seq_eq_at_seq _ _ _,
    exact prod.mk_is_nonexpansive α β,
    exact nonexpansive core hac,
    exact nonexpansive core hbd,
  end⟩,
  extend := λ n a b₁ b₂ h₁ h₂,
    (((extend h₁.1 h₂.1).1, (extend h₁.2 h₂.2).1), ((extend h₁.1 h₂.1).2, (extend h₁.2 h₂.2).2)),
  mul_is_nonexpansive := prod.camera.mul_is_nonexpansive,
  core_mul_self := prod.camera.core_mul_self,
  core_core := prod.camera.core_core,
  core_mono_some := prod.camera.core_mono_some,
  core_mono := prod.camera.core_mono,
  validn_mul := prod.camera.validn_mul,
  extend_mul_eq := prod.camera.extend_mul_eq,
  extend_eq_at_left := prod.camera.extend_eq_at_left,
  extend_eq_at_right := prod.camera.extend_eq_at_right,
  ..prod.ofe,
  ..prod.comm_semigroup,
}

lemma prod.can_update {α β : Type u} [camera α] [camera β] {a : α} {b : β} {A : set α} {B : set β} :
  a ↝ A → b ↝ B → (a, b) ↝ A ×ˢ B :=
begin
  rintros haA hbB n ⟨⟨c, d⟩, ⟨hc, hd⟩⟩,
  obtain ⟨fa, hfa⟩ := haA n ⟨c, hc⟩,
  obtain ⟨fb, hfb⟩ := hbB n ⟨d, hd⟩,
  exact ⟨⟨(fa.val, fb.val), fa.prop, fb.prop⟩, hfa, hfb⟩,
end


/-
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.algebraic_geometry.presheafed_space
import Mathlib.topology.category.Top.limits
import Mathlib.topology.sheaves.limits
import Mathlib.category_theory.limits.concrete_category
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# `PresheafedSpace C` has colimits.

If `C` has limits, then the category `PresheafedSpace C` has colimits,
and the forgetful functor to `Top` preserves these colimits.

When restricted to a diagram where the underlying continuous maps are open embeddings,
this says that we can glue presheaved spaces.

Given a diagram `F : J ⥤ PresheafedSpace C`,
we first build the colimit of the underlying topological spaces,
as `colimit (F ⋙ PresheafedSpace.forget C)`. Call that colimit space `X`.

Our strategy is to push each of the presheaves `F.obj j`
forward along the continuous map `colimit.ι (F ⋙ PresheafedSpace.forget C) j` to `X`.
Since pushforward is functorial, we obtain a diagram `J ⥤ (presheaf C X)ᵒᵖ`
of presheaves on a single space `X`.
(Note that the arrows now point the other direction,
because this is the way `PresheafedSpace C` is set up.)

The limit of this diagram then constitutes the colimit presheaf.
-/

namespace algebraic_geometry

namespace PresheafedSpace

@[simp] theorem map_id_c_app {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] (F : J ⥤ PresheafedSpace C) (j : J) (U : topological_space.opens ↥(carrier (category_theory.functor.obj F j))) : category_theory.nat_trans.app (hom.c (category_theory.functor.map F 𝟙)) (opposite.op U) =
  category_theory.nat_trans.app
      (category_theory.iso.inv
        (Top.presheaf.pushforward.id (PresheafedSpace.presheaf (category_theory.functor.obj F j))))
      (opposite.op U) ≫
    category_theory.nat_trans.app
      (category_theory.iso.hom
        (Top.presheaf.pushforward_eq
          (eq.mpr
            (id
              ((fun (a a_1 : carrier (category_theory.functor.obj F j) ⟶ carrier (category_theory.functor.obj F j))
                  (e_1 : a = a_1)
                  (ᾰ ᾰ_1 : carrier (category_theory.functor.obj F j) ⟶ carrier (category_theory.functor.obj F j))
                  (e_2 : ᾰ = ᾰ_1) => congr (congr_arg Eq e_1) e_2)
                𝟙 𝟙 (Eq.refl 𝟙) (hom.base (category_theory.functor.map F 𝟙)) 𝟙
                (Eq.trans
                  ((fun (c c_1 : hom (category_theory.functor.obj F j) (category_theory.functor.obj F j))
                      (e_1 : c = c_1) => congr_arg hom.base e_1)
                    (category_theory.functor.map F 𝟙) 𝟙 (category_theory.functor.map_id F j))
                  (id_base (category_theory.functor.obj F j)))))
            (Eq.refl 𝟙))
          (PresheafedSpace.presheaf (category_theory.functor.obj F j))))
      (opposite.op U) := sorry

@[simp] theorem map_comp_c_app {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] (F : J ⥤ PresheafedSpace C) {j₁ : J} {j₂ : J} {j₃ : J} (f : j₁ ⟶ j₂) (g : j₂ ⟶ j₃) (U : topological_space.opens ↥(carrier (category_theory.functor.obj F j₃))) : category_theory.nat_trans.app (hom.c (category_theory.functor.map F (f ≫ g))) (opposite.op U) =
  category_theory.nat_trans.app (hom.c (category_theory.functor.map F g)) (opposite.op U) ≫
    category_theory.nat_trans.app
        (Top.presheaf.pushforward_map (hom.base (category_theory.functor.map F g))
          (hom.c (category_theory.functor.map F f)))
        (opposite.op U) ≫
      category_theory.nat_trans.app
          (category_theory.iso.inv
            (Top.presheaf.pushforward.comp (PresheafedSpace.presheaf (category_theory.functor.obj F j₁))
              (hom.base (category_theory.functor.map F f)) (hom.base (category_theory.functor.map F g))))
          (opposite.op U) ≫
        category_theory.nat_trans.app
          (category_theory.iso.hom
            (Top.presheaf.pushforward_eq
              (eq.mpr
                (id
                  (Eq._oldrec
                    (Eq.refl
                      (hom.base (category_theory.functor.map F f) ≫ hom.base (category_theory.functor.map F g) =
                        hom.base (category_theory.functor.map F (f ≫ g))))
                    (category_theory.functor.map_comp F f g)))
                (Eq.refl (hom.base (category_theory.functor.map F f) ≫ hom.base (category_theory.functor.map F g))))
              (PresheafedSpace.presheaf (category_theory.functor.obj F j₁))))
          (opposite.op U) := sorry

/--
Given a diagram of presheafed spaces,
we can push all the presheaves forward to the colimit `X` of the underlying topological spaces,
obtaining a diagram in `(presheaf C X)ᵒᵖ`.
-/
@[simp] theorem pushforward_diagram_to_colimit_obj {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] (F : J ⥤ PresheafedSpace C) (j : J) : category_theory.functor.obj (pushforward_diagram_to_colimit F) j =
  opposite.op
    (category_theory.limits.colimit.ι (F ⋙ forget C) j _* PresheafedSpace.presheaf (category_theory.functor.obj F j)) :=
  Eq.refl (category_theory.functor.obj (pushforward_diagram_to_colimit F) j)

/--
Auxilliary definition for `PresheafedSpace.has_colimits`.
-/
def colimit {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] (F : J ⥤ PresheafedSpace C) : PresheafedSpace C :=
  mk (category_theory.limits.colimit (F ⋙ forget C))
    (category_theory.limits.limit (category_theory.functor.left_op (pushforward_diagram_to_colimit F)))

/--
Auxilliary definition for `PresheafedSpace.has_colimits`.
-/
@[simp] theorem colimit_cocone_X {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] (F : J ⥤ PresheafedSpace C) : category_theory.limits.cocone.X (colimit_cocone F) = colimit F :=
  Eq.refl (category_theory.limits.cocone.X (colimit_cocone F))

namespace colimit_cocone_is_colimit

/--
Auxilliary definition for `PresheafedSpace.colimit_cocone_is_colimit`.
-/
def desc_c_app {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] (F : J ⥤ PresheafedSpace C) (s : category_theory.limits.cocone F) (U : topological_space.opens ↥(carrier (category_theory.limits.cocone.X s))ᵒᵖ) : category_theory.functor.obj (PresheafedSpace.presheaf (category_theory.limits.cocone.X s)) U ⟶
  category_theory.functor.obj
    (category_theory.limits.colimit.desc (F ⋙ forget C) (category_theory.functor.map_cocone (forget C) s) _*
      category_theory.limits.limit (category_theory.functor.left_op (pushforward_diagram_to_colimit F)))
    U := sorry

theorem desc_c_naturality {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] (F : J ⥤ PresheafedSpace C) (s : category_theory.limits.cocone F) {U : topological_space.opens ↥(carrier (category_theory.limits.cocone.X s))ᵒᵖ} {V : topological_space.opens ↥(carrier (category_theory.limits.cocone.X s))ᵒᵖ} (i : U ⟶ V) : category_theory.functor.map (PresheafedSpace.presheaf (category_theory.limits.cocone.X s)) i ≫ desc_c_app F s V =
  desc_c_app F s U ≫
    category_theory.functor.map
      (category_theory.limits.colimit.desc (F ⋙ forget C) (category_theory.functor.map_cocone (forget C) s) _*
        PresheafedSpace.presheaf (category_theory.limits.cocone.X (colimit_cocone F)))
      i := sorry

end colimit_cocone_is_colimit

/--
Auxilliary definition for `PresheafedSpace.has_colimits`.
-/
def colimit_cocone_is_colimit {J : Type v} [category_theory.small_category J] {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] (F : J ⥤ PresheafedSpace C) : category_theory.limits.is_colimit (colimit_cocone F) :=
  category_theory.limits.is_colimit.mk
    fun (s : category_theory.limits.cocone F) =>
      hom.mk (category_theory.limits.colimit.desc (F ⋙ forget C) (category_theory.functor.map_cocone (forget C) s))
        (category_theory.nat_trans.mk
          fun (U : topological_space.opens ↥(carrier (category_theory.limits.cocone.X s))ᵒᵖ) => sorry)

/--
When `C` has limits, the category of presheaved spaces with values in `C` itself has colimits.
-/
protected instance category_theory.limits.has_colimits {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] : category_theory.limits.has_colimits (PresheafedSpace C) :=
  category_theory.limits.has_colimits.mk
    fun (J : Type v) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_colimits_of_shape.mk
        fun (F : J ⥤ PresheafedSpace C) =>
          category_theory.limits.has_colimit.mk
            (category_theory.limits.colimit_cocone.mk (colimit_cocone F) (colimit_cocone_is_colimit F))

/--
The underlying topological space of a colimit of presheaved spaces is
the colimit of the underlying topological spaces.
-/
protected instance forget_preserves_colimits {C : Type u} [category_theory.category C] [category_theory.limits.has_limits C] : category_theory.limits.preserves_colimits (forget C) :=
  category_theory.limits.preserves_colimits.mk
    fun (J : Type v) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.preserves_colimits_of_shape.mk
        fun (F : J ⥤ PresheafedSpace C) =>
          category_theory.limits.preserves_colimit_of_preserves_colimit_cocone (colimit_cocone_is_colimit F)
            (category_theory.limits.is_colimit.of_iso_colimit (category_theory.limits.colimit.is_colimit (F ⋙ forget C))
              (category_theory.limits.cocones.ext
                (category_theory.iso.refl
                  (category_theory.limits.cocone.X (category_theory.limits.colimit.cocone (F ⋙ forget C))))
                sorry))


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import for_mathlib.algebraic_topology.homotopical_algebra.fibrant

noncomputable theory

open category_theory
open category_theory.limits
open category_theory.category
open algebraic_topology
open opposite

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]

namespace brown_factorisation

variables {X Y : C} (f : X ⟶ Y)

namespace cofibrant

def obj := CM5b.obj (coprod.desc f (𝟙 Y))

def i : X ⟶ obj f := coprod.inl ≫ CM5b.i (coprod.desc f (𝟙 Y))
def p : obj f ⟶ Y := CM5b.p (coprod.desc f (𝟙 Y))
def s : Y ⟶ obj f := coprod.inr ≫ CM5b.i (coprod.desc f (𝟙 Y))

@[simp, reassoc]
lemma fac₁ : i f ≫ p f = f :=
by simp only [i, p, assoc, factorisation_axiom.fac, coprod.inl_desc]

@[simp, reassoc]
lemma fac₂ : s f ≫ p f = 𝟙 Y :=
by simp only [s, p, assoc, factorisation_axiom.fac, coprod.inr_desc]

instance weak_eq_p : weak_eq (p f) := by { dsimp [p], apply_instance, }

instance weak_eq_s : weak_eq (s f) :=
weak_eq.of_comp_right (s f) (p f) infer_instance (by { rw fac₂, apply_instance, })

instance weak_eq_i [weak_eq f] : weak_eq (i f) :=
weak_eq.of_comp_right (i f) (p f) infer_instance (by { rw fac₁, apply_instance, })

instance fibration_p : fibration (p f) := by { dsimp [p], apply_instance, }
instance fib_obj [is_fibrant Y] : is_fibrant (obj f) :=
is_fibrant.mk (p f ≫ terminal.from Y) terminal_is_terminal

instance cof_i [is_cofibrant Y] : cofibration (i f) := by { dsimp [i], apply_instance, }
instance cof_s [is_cofibrant X] : cofibration (s f) := by { dsimp [s], apply_instance, }
instance cof_obj [is_cofibrant X] [is_cofibrant Y] : is_cofibrant (obj f) :=
is_cofibrant.mk (initial.to X ≫ i f) initial_is_initial

end cofibrant

namespace fibrant

def obj := (cofibrant.obj f.op).unop

def i : X ⟶ obj f := (cofibrant.p f.op).unop
def p : obj f ⟶ Y := (cofibrant.i f.op).unop
def r : obj f ⟶ X := (cofibrant.s f.op).unop

@[simp, reassoc]
lemma fac₁ : i f ≫ p f = f :=
by { dsimp only [i, p], rw [← unop_comp, cofibrant.fac₁, f.unop_op], }

@[simp, reassoc]
lemma fac₂ : i f ≫ r f = 𝟙 _ :=
by { dsimp only [i, r], rw [← unop_comp, cofibrant.fac₂], refl, }

instance weak_eq_i : weak_eq (i f) := (infer_instance : weak_eq (cofibrant.p f.op)).unop
instance weak_eq_r : weak_eq (r f) := (infer_instance : weak_eq (cofibrant.s f.op)).unop
instance weak_eq_p [hf : weak_eq f] : weak_eq (p f) :=
by { haveI := hf.op, apply weak_eq.unop, apply_instance, }

instance cof_i : cofibration (i f) := (infer_instance : fibration (cofibrant.p f.op)).unop
instance cof_obj [is_cofibrant X] : is_cofibrant (obj f) :=
is_cofibrant.mk (initial.to X ≫ i f) initial_is_initial

instance fib_p [hX : is_fibrant X] : fibration (p f) :=
by { haveI := hX.op, apply cofibration.unop, apply_instance, }
instance fib_s [hY : is_fibrant Y] : fibration (r f) :=
by { haveI := hY.op, apply cofibration.unop, apply_instance, }
instance fib_obj [is_fibrant X] [is_fibrant Y] : is_fibrant (obj f) :=
is_fibrant.mk (p f ≫ terminal.from Y) terminal_is_terminal

end fibrant

end brown_factorisation

end model_category

end algebraic_topology