import order

import lib.list

import etv
import main.lemmas.join_n2_n3_n2

open order_dual

variables {α : Type*} [linear_order α] (C : config α)

lemma config.join_n2_n2_interweaved {S : finset α} {n : ℕ}
  {c1 : list α} (c1_cup : C.ncup (n+2) c1) (c1_in_S : c1.in S)
  {c2 : list α} (c2_cup : C.ncup (n+2) c2) (c2_in_S : c2.in S)
  (x : α) (c1_last : x ∈ c1.last') (c2_head : x ∈ c2.head') :
  ∃ p q r s, C.has_interweaved_laced (n+2) S p q r s :=
begin
  rcases c1_cup.take_head_last with ⟨p, c1', q, eq_c1, c1'_cup⟩,
  rcases c2_cup.take_head_last with ⟨q, c2', r, eq_c2, c2'_cup⟩,
  rw eq_c1 at c1_last, rw eq_c2 at c2_head,
  simp at c1_last c2_head, subst c1_last, subst c2_head,
  use [p, q, q, r], refine ⟨_, _, _⟩,
  { refine ⟨_, _, _⟩,
    rw eq_c1 at c1_cup, apply c1_cup.head'_lt_last' p q; simp, simp,
    rw eq_c2 at c2_cup, apply c2_cup.head'_lt_last' q r; simp, },
  { existsi [1, n+1, [p], c1, c2.init, _, c1_cup, c2_cup.init], swap, simp,
    rw eq_c1 at ⊢ c1_in_S, rw eq_c2 at ⊢ c2_in_S,
    simp at ⊢ c1_in_S c2_in_S, ring_nf, tauto, },
  { existsi [n+1, 1, c1.tail, c2, [r], c1_cup.tail, c2_cup, _], swap, simp,
    rw eq_c1 at ⊢ c1_in_S, rw eq_c2 at ⊢ c2_in_S,
    simp at ⊢ c1_in_S c2_in_S, tauto, },
end

lemma config.join_n2_n3_join_n3_n2_main (S : finset α) (n : ℕ)
  (cap4_free : ¬C.has_ncap 4 S) (cup_free : ¬C.has_ncup (n+4) S)
  {cx : list α} (cx_cup : C.ncup (n+2) cx) (cx_in_S : cx.in S)
  {cx1 : list α} (cx1_cup : C.ncup (n+3) cx1) (cx1_in_S : cx1.in S)
  {cy1 : list α} (cy1_cup : C.ncup (n+3) cy1) (cy1_in_S : cy1.in S)
  {cy : list α} (cy_cup : C.ncup (n+2) cy) (cy_in_S : cy.in S)
  (x : α) (cx_last : x ∈ cx.last') (cx1_head : x ∈ cx1.head')
  (y : α) (cy1_last : y ∈ cy1.last') (cy_head : y ∈ cy.head') :
  ∃ p q r s, C.has_interweaved_laced (n+3) S p q r s :=
begin
  have l := cap4_free_label cap4_free,
  have x_in_S := cx_in_S _ (list.mem_of_mem_last' cx_last),
  have y_in_S := cy_in_S _ (list.mem_of_mem_head' cy_head),
  rcases lt_or_le y x with hxy | hxy,
  -- Case y < x
  { by_cases lyx : l.slope y x,
    { exfalso, apply cup_free, use cy1 ++ [x], split,
      apply cy1_cup.extend_right lyx; try { assumption },
      simp, split; assumption, },
    { exfalso, apply cup_free, use y :: cx1, split,
      apply cx1_cup.extend_left lyx; try { assumption },
      simp, split; assumption }, },
  -- Case x ≤ y
  rcases cx1_cup.take_head_last with ⟨x, cx1', z, eq_cx1, cx1'_cup⟩,
  rw eq_cx1 at cx1_head, simp at cx1_head, subst cx1_head,
  rcases cy1_cup.take_head_last with ⟨w, cy1', y, eq_cy1, cy1'_cup⟩,
  rw eq_cy1 at cy1_last, simp at cy1_last, subst cy1_last,
  have z_in_S : z ∈ S := by rw eq_cx1 at cx1_in_S; simp at cx1_in_S; tauto,
  have w_in_S : w ∈ S := by rw eq_cy1 at cy1_in_S; simp at cy1_in_S; tauto,
  rcases lt_trichotomy x w with hwx | hwx | hwx, swap,
  { subst hwx, apply C.join_n2_n3_n2 S cap4_free cup_free
      cx_cup cx_in_S cy1_cup cy1_in_S cy_cup cy_in_S
      x cx_last _ y _ cy_head; rw eq_cy1; simp, },
  { by_cases lxw : l.slope x w,
    { have cxw_cup : C.ncup (n + 3) (cx ++ [w]) :=
        by apply cx_cup.extend_right lxw; try {assumption},
      apply C.join_n2_n2_interweaved cxw_cup _ cy1_cup cy1_in_S w,
      simp, rw eq_cy1, simp, simp, tauto, },
    { exfalso, apply cup_free, use x :: cy1, split,
      apply cy1_cup.extend_left lxw; try {assumption}, rw eq_cy1, simp,
      simp, split; assumption, }, },
  -- w < x
  rcases lt_trichotomy z y with hyz | hyz | hyz, swap,
  { subst hyz, apply C.join_n2_n3_n2 S cap4_free cup_free
      cx_cup cx_in_S cx1_cup cx1_in_S cy_cup cy_in_S
      x cx_last _ z _ cy_head; rw eq_cx1; simp, },
  { by_cases lzy : l.slope z y,
    { exfalso, apply cup_free, use cx1 ++ [y], split,
      apply cx1_cup.extend_right lzy; try {assumption}, rw eq_cx1, simp,
      simp, split; assumption, },
    { have zcy_cup : C.ncup (n + 3) (z :: cy) :=
        by apply cy_cup.extend_left lzy; try {assumption},
      apply C.join_n2_n2_interweaved cx1_cup _ zcy_cup _ z,
      rw eq_cx1, simp, simp, tauto, simp, tauto, }, },
  -- y < z
  use [w, x, y, z], refine ⟨_, _, _⟩, tauto,
  { existsi [1, n+2, [w], cy1, cy, _, cy1_cup, cy_cup], swap, simp,
    split, simp, tauto, split, ring_nf, rw eq_cy1, simp, assumption, },
  { existsi [n+2, 1, cx, cx1, [z], cx_cup, cx1_cup, _], swap, simp,
    split, simp, tauto, split, ring_nf, rw eq_cx1, simp, assumption, },
end

lemma config.join_n2_n3_join_n3_n2 (S : finset α) (n : ℕ)
  (cap4_free : ¬C.has_ncap 4 S) (cup_free : ¬C.has_ncup (n+4) S)
  (hx : C.has_join (n+2) (n+3) S) (hy : C.has_join (n+3) (n+2) S) :
  ∃ p q r s, C.has_interweaved_laced (n+3) S p q r s :=
begin
  rcases hx with ⟨x, cx, cx1,
    ⟨cx_cup, cx_in_S, cx_last⟩, ⟨cx1_cup, cx1_in_S, cx1_head⟩⟩,
  rcases hy with ⟨y, cy1, cy,
    ⟨cy1_cup, cy1_in_S, cy1_last⟩, ⟨cy_cup, cy_in_S, cy_head⟩⟩,
  apply C.join_n2_n3_join_n3_n2_main S n
    cap4_free cup_free cx_cup cx_in_S cx1_cup cx1_in_S
    cy1_cup cy1_in_S cy_cup cy_in_S x cx_last cx1_head
    y cy1_last cy_head,
end


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .operators
import .linear
import .stream_elim
import .incremental

import tactic.induction

namespace ckt.

section ckts.

parameter (Func: ∀ (a b: Type) [add_comm_group a] [add_comm_group b], Type).
parameter (Func_denote: ∀ {a b: Type} [add_comm_group a] [add_comm_group b], Func a b → (a → b)).

inductive ckt : ∀ (a b: Type) [add_comm_group a] [add_comm_group b], Type 1
| delay {a: Type} [add_comm_group a]
  : ckt a a
| derivative {a: Type} [add_comm_group a]
  : ckt a a
| integral {a: Type} [add_comm_group a]
  : ckt a a
| incremental {a b: Type} [add_comm_group a] [add_comm_group b]
  (f: ckt a b) : ckt a b
| lifting {a b: Type} [add_comm_group a] [add_comm_group b]
  (f: Func a b) : ckt a b
-- | ckt_lift {a b: Type} [add_comm_group a] [add_comm_group b]
--   (f: ckt a b) : ckt (stream a) (stream b)
| seq {a b c: Type} [add_comm_group a] [add_comm_group b] [add_comm_group c]
  (f1: ckt a b) (f2: ckt b c) : ckt a c
| par {a₁ b₁ a₂ b₂: Type}
  [add_comm_group a₁] [add_comm_group a₂] [add_comm_group b₁] [add_comm_group b₂]
  (f1: ckt a₁ b₁) (f2: ckt a₂ b₂) : ckt (a₁ × a₂) (b₁ × b₂)
| feedback {a b: Type} [add_comm_group a] [add_comm_group b]
  (F: ckt (a × b) b) : ckt a b
-- | intro {a: Type} [add_comm_group a]
--   : ckt a (stream a)
-- | elim {a: Type} [add_comm_group a]
--   : ckt (stream a) a
.

local notation f1 ` ~~> ` f2:25 := ckt _ f1 f2.

variables {a b c d: Type} [add_comm_group a] [add_comm_group b] [add_comm_group c] [add_comm_group d].

section denote.

include Func_denote.

def denote (c: ckt a b) : (stream a → stream b) :=
begin
  -- unfreezingI { revert_deps a b, revert a b, },
  -- apply (@ckt.rec (λ {a b: Type} [_i1: add_comm_group a] [_i2: add_comm_group b] (f: @ckt a b _i1 _i2), (stream a → stream b))); dsimp; introv; resetI,

  -- resetI resets the (typeclass) instance cache, so that the new local
  -- hypotheses can be used for instance search
  -- unfortunately we need this unfreezingI thing and induction rather than
  -- mathlib induction' because of its improper handling of dependencies
  unfreezingI { induction c } ,
  { resetI, apply delay, },
  { resetI, apply D, },
  { resetI, apply I, },
  { resetI, apply c_ih^Δ, },
  { resetI, apply ↑↑(Func_denote c_f), },
  { -- seq
    exact (λ a, c_ih_f2 (c_ih_f1 a)), },
  { -- par
     resetI,
     apply (uncurry_op (λ x1 x2, sprod (c_ih_f1 x1, c_ih_f2 x2))), },
  { -- feedback
    resetI,
    intros s,
    apply fix (λ α, c_ih (sprod (s, z⁻¹ α))),
  },
  -- { resetI, exact ↑↑δ0, },
  -- { resetI, exact ↑↑stream_elim, }
end
end denote.

def equiv (f1 f2: ckt a b) := denote f1 = denote f2.

local infix ` === `:50 := equiv.

@[refl]
lemma equiv_refl (f: ckt a b) : f === f :=
  by { unfold equiv }.

@[symm]
lemma equiv_symm (f1 f2: ckt a b) : f1 === f2 → f2 === f1 :=
  by { unfold equiv, cc, }.

@[trans]
lemma equiv_trans (f1 f2 f3: ckt a b) : f1 === f2 → f2 === f3 → f1 === f3 :=
  by { unfold equiv, cc, }.

@[simp]
lemma denote_seq (f1: ckt a b) (f2: ckt b c) :
  denote (ckt.seq f1 f2) = λ x, denote f2 (denote f1 x) := rfl.

@[simp]
lemma denote_par
  (f1: ckt a b) (f2: ckt c d) :
  denote (ckt.par f1 f2) = uncurry_op (λ x1 x2, sprod (denote f1 x1, denote f2 x2))
  := rfl.

@[simp]
lemma denote_delay :
  denote (@ckt.delay a _) = delay := rfl.

@[simp]
lemma denote_derivative :
  denote (@ckt.derivative a _) = D := rfl.

@[simp]
lemma denote_incremental (f: ckt a b) :
  denote (ckt.incremental f) = (denote f)^Δ := rfl.

@[simp]
lemma denote_integral :
  denote (@ckt.integral a _) = I := rfl.

@[simp]
lemma denote_lifting (f: Func a b) :
  denote (ckt.lifting f) = ↑↑(Func_denote f) := rfl.

-- @[simp]
-- lemma denote_ckt_lift (f: ckt a b) :
--   denote (ckt.ckt_lift f) = ↑↑(denote f) := rfl.

@[simp]
lemma denote_feedback (F: ckt (a × b) b) :
  denote (ckt.feedback F) = λ s, fix (λ α, denote F (sprod (s, z⁻¹ α))) := rfl.

-- @[simp]
-- lemma denote_intro :
--   denote (@ckt.intro a _) = ↑↑δ0 := rfl.
--
-- @[simp]
-- lemma stream_elim_intro :
--   denote (@ckt.elim a _) = ↑↑∫ := rfl.

local notation x ` >>> `:55 y:55 := ckt.seq x y.

-- These definitions rely on being able to lift a few fixed functions; they
-- still make sense, but with relatively complicated assumptions that these
-- functions are available in [Func] with the appropriate meaning according to
-- [Func_denote].
/-
def lifting2 (f: a → b → c) : ckt (a × b) c :=
  ckt.lifting (λ xy, f xy.1 xy.2).

def derivative : ckt a a :=
  ckt.lifting (λ a, (a, a)) >>> ckt.par (ckt.lifting id) ckt.delay >>>
  ckt.lifting2 (λ x y, x - y).

theorem derivative_denote :
  @derivative a _ === ckt.derivative :=
begin
  unfold derivative,
  funext s, simp,
  unfold lifting2, simp,
  funext t, simp,
  refl,
end

def integral : ckt a a :=
  ckt.feedback (ckt.lifting2 (λ x y, x + y)).

theorem integral_denote :
  @integral a _ === ckt.integral :=
begin
  unfold integral,
  funext s, simp,
  unfold lifting2, simp,
  unfold I feedback, simp,
  refl,
end
-/

def ckt_causal (f: ckt a b) : causal (denote f) :=
begin
  unfreezingI { induction f }; resetI; try { simp },
  { apply delay_causal, },
  { apply causal_incremental, assumption, },
  { apply causal_comp_causal; assumption, },
  { rw causal2,
    introv heq1 heq2,
    simp,
    split,
    { apply f_ih_f1, assumption, },
    { apply f_ih_f2, assumption, },
  },
  { apply (feedback_ckt_causal delay _ (λ (s: stream f_a) (α: stream f_b), ckt.denote f_F (sprod (s, α)))),
    rw causal2,
    introv heq1 heq2,
    apply f_ih,
    intros m hle, simp,
    split, { apply heq1, omega, }, { apply heq2, omega, },
    apply delay_strict,
  },
end

def is_strict (f: ckt a b) : {b:bool | b → strict (denote f)} :=
begin
  unfreezingI { induction f }; simp,
  { use true, simp, apply delay_strict, },
  { -- derivative
    use false, },
  { -- integral
    use false, },
  { -- incremental
    cases f_ih with b hstrict, simp at *,
    use b, intros hb,
    unfold incremental,
    apply causal_strict_strict, swap, simp,
    apply strict_causal_strict, simp,
    tauto,
  },
  { -- lifting
    use false, },
  { -- seq (composition)
    cases f_ih_f1 with b1 hstrict1,
    cases f_ih_f2 with b2 hstrict2, simp at *,
    use (b1 || b2), simp,
    intros h, cases h; resetI,
    apply causal_strict_strict, tauto, apply ckt_causal,
    apply strict_causal_strict, apply ckt_causal, tauto,
   },
  { -- par
    cases f_ih_f1 with b1 hstrict1, cases f_ih_f2 with b2 hstrict2,
    use (b1 && b2), simp at *, intros h1 h2,
    intros s1 s2 n heq,
    unfold uncurry_op sprod, simp,
    split,
    { apply (hstrict1 h1), intros, simp, rw heq, omega, },
    { apply (hstrict2 h2), intros, simp, rw heq, omega, },
   },
   { use false, },
end

/-
def incrementalize (f: ckt a b) : ckt a b :=
  ckt.integral >>> f >>> ckt.derivative.

theorem incrementalize_ok (f: ckt a b) :
 denote (incrementalize f) = (denote f)^Δ :=
begin
  unfold incrementalize, simp,
  funext s, rw incremental_unfold,
end
-/

theorem seq_assoc (f1: ckt a b) (f2: ckt b c) (f3: ckt c d) :
  f1 >>> f2 >>> f3 === f1 >>> (f2 >>> f3) :=
begin
  unfold equiv, simp,
end

section recursive_opt.

variables (opt: Π {a b: Type} [inst1: add_comm_group a] [inst2: add_comm_group b],
      @ckt a b inst1 inst2 → option (@ckt a b inst1 inst2)).

include opt
def recursive_opt : ckt a b → ckt a b :=
begin
  intros f, unfreezingI { induction f },
  { apply (opt $ ckt.delay).get_or_else ckt.delay, },
  { apply (opt $ ckt.derivative).get_or_else ckt.derivative, },
  { apply (opt $ ckt.integral).get_or_else ckt.integral, },
  { apply (opt $ ckt.incremental f_f).get_or_else (ckt.incremental f_ih), },
  { resetI, apply (opt $ ckt.lifting f_f).get_or_else (ckt.lifting f_f), },
  { resetI, apply (opt $ ckt.seq f_f1 f_f2).get_or_else (ckt.seq f_ih_f1 f_ih_f2), },
  { resetI, apply (opt $ ckt.par f_f1 f_f2).get_or_else (ckt.par f_ih_f1 f_ih_f2), },
  { resetI, apply (opt $ ckt.feedback f_F).get_or_else (ckt.feedback f_ih), },
  -- { apply (opt $ ckt.intro).get_or_else ckt.intro, },
  -- { apply (opt $ ckt.elim).get_or_else ckt.elim, },
end

@[simp]
lemma recursive_opt_seq (f1: ckt a b) (f2: ckt b c) :
  recursive_opt @opt (ckt.seq f1 f2) =
    (opt $ ckt.seq f1 f2).get_or_else (ckt.seq (recursive_opt @opt f1) (recursive_opt @opt f2)) := rfl.

@[simp]
lemma recursive_opt_par (f1: ckt a b) (f2: ckt c d) :
  recursive_opt @opt (ckt.par f1 f2) =
    (opt $ ckt.par f1 f2).get_or_else (ckt.par (recursive_opt @opt f1) (recursive_opt @opt f2)) := rfl.

@[simp]
lemma recursive_opt_feedback (f: ckt (a × b) b) :
  recursive_opt @opt (ckt.feedback f) =
    (opt $ ckt.feedback f).get_or_else (ckt.feedback (recursive_opt @opt f)) := rfl.

@[simp]
lemma recursive_opt_incremental (f: ckt a b) :
  recursive_opt @opt (ckt.incremental f) =
    (opt $ ckt.incremental f).get_or_else (ckt.incremental (recursive_opt @opt f)) := rfl.

variables (h_opt: ∀ {a b: Type} [inst1: add_comm_group a] [inst2: add_comm_group b]
  (f1 f2: @ckt.ckt a b inst1 inst2),
    @opt a b inst1 inst2 f1 = some f2 ->
    @ckt.equiv a b inst1 inst2 f1 f2).

include h_opt

lemma opt_or_else_ok (f1 f2: ckt a b) :
  f2 === f1 →
  (opt f1).get_or_else f2 === f1 :=
begin
  intros heq,
  destruct (opt f1); introv hopt; rw hopt; simp,
  assumption,
  symmetry, apply h_opt, assumption,
end

theorem recursive_opt_ok :
  ∀ (f: ckt a b), recursive_opt @opt f === f :=
begin
  intros f, unfreezingI { induction f },
  { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, },
  { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, },
  { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, },
  { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt),
    unfold equiv at f_ih |-,
    simp, dsimp, rw f_ih, },
  { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, },
  { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt),
    unfold equiv at f_ih_f1 f_ih_f2 |-,
    simp, dsimp, rw [f_ih_f2, f_ih_f1],
  },
  { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt),
    unfold equiv at f_ih_f1 f_ih_f2 |-,
    simp, dsimp, rw [f_ih_f1, f_ih_f2],
  },
  { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt),
    unfold equiv at f_ih |-,
    simp, dsimp, rw f_ih,
  },
end

end recursive_opt.

section incrementalize.

parameters (is_linear: ∀ {a b: Type} [i1: add_comm_group a] [i2: add_comm_group b]
                      (f: @Func a b i1 i2), bool)
          (is_linear_ok: ∀ {a b: Type} [i1: add_comm_group a] [i2: add_comm_group b]
            (f: @Func a b i1 i2), @is_linear _ _ i1 i2 f →
            ∀ (x y: a),
            -- use tactic mode to run resetI; something is weird about
            -- elaboration here where instances aren't picked up
            (by { resetI,
            exact Func_denote f (x + y) = Func_denote f x + Func_denote f y })).

include is_linear.

-- returns an optimized version of c^Δ
def incrementalize (c: ckt a b) : ckt a b :=
begin
  unfreezingI { induction c },
  { exact ckt.delay, },
  { exact ckt.derivative, },
  { exact ckt.integral, },
  { apply ckt.incremental c_ih, },
  { apply (if is_linear c_f
          then ckt.lifting c_f
          else ckt.incremental (ckt.lifting c_f)), },
  { apply ckt.seq c_ih_f1 c_ih_f2, },
  { apply ckt.par c_ih_f1 c_ih_f2, },
  { apply ckt.feedback c_ih, },
end

@[simp]
lemma incrementalize_incremental (c: ckt a b) :
  incrementalize (ckt.incremental c) = ckt.incremental (incrementalize c) := rfl.

@[simp]
lemma incrementalize_lifting (f: Func a b) :
  incrementalize (ckt.lifting f) =
  if is_linear f then
  ckt.lifting f else ckt.incremental (ckt.lifting f) := rfl.

@[simp]
lemma incrementalize_seq (f1: ckt a b) (f2: ckt b c) :
  incrementalize (f1 >>> f2) = incrementalize f1 >>> incrementalize f2 := rfl.

@[simp]
lemma incrementalize_par (f1: ckt a b) (f2: ckt c d) :
  incrementalize (ckt.par f1 f2) = ckt.par (incrementalize f1) (incrementalize f2) := rfl.

@[simp]
lemma incrementalize_feedback (f: ckt (a × b) b) :
  incrementalize (ckt.feedback f) = ckt.feedback (incrementalize f) := rfl.

include is_linear_ok.

theorem incrementalize_ok (f: ckt a b) :
 denote (incrementalize f) = (denote f)^Δ :=
begin
  unfreezingI { induction f, }; try { unfold incrementalize; simp; done },
  { simp, rw f_ih, },
  { simp, split_ifs,
    { simp, rw lti_incremental,
      apply lifting_lti,
      intros, apply is_linear_ok, assumption,
    },
    { simp, },
  },
  { simp, rw [f_ih_f1, f_ih_f2],
    funext s,
    rw (incremental_comp
      (denote _ @Func_denote f_f2) (denote _ @Func_denote f_f1)), },
  { simp, funext s,
    rw [f_ih_f1, f_ih_f2],
    unfold uncurry_op,
    unfold incremental,
    rw [derivative_sprod, integral_fst_comm, integral_snd_comm],
  },
  { simp,
    rw cycle_incremental (λ s α, denote _ @Func_denote f_F (sprod (s, α))),
    { dsimp,
      rw f_ih,
      funext s,
      congr' 1, funext α,
      rw incremental_sprod, },
    { dsimp,
      rw causal2, introv heq1 heq2,
      apply ckt_causal,
      intros t hle, simp,
      rw [heq1, heq2], finish, assumption, assumption,
    },
  },
end

end incrementalize.

end ckts.
end ckt.


import category_theory.abelian.projective
import category_theory.limits.preserves.finite
import for_mathlib.abelian_category

noncomputable theory

universes v v' u

open category_theory category_theory.limits

namespace category_theory

/-- `endomorphisms C` is the category whose objects are an object of `C` equipped with an
endomorphism. Morphisms are morphisms between objects which intertwine the endomorphisms. -/
structure endomorphisms (C : Type u) [category.{v} C] :=
(X : C)
(e : End X)

namespace endomorphisms

section category

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

@[ext] protected structure hom (X Y : endomorphisms C) :=
(f : X.X ⟶ Y.X)
(comm : X.e ≫ f = f ≫ Y.e)

attribute [reassoc, simp] hom.comm

instance (C : Type u) [category.{v} C] : quiver (endomorphisms C) :=
{ hom := λ X Y, hom X Y }

lemma f_injective (X Y : endomorphisms C) : function.injective (hom.f : (X ⟶ Y) → (X.X ⟶ Y.X)) :=
by { intros f g h, ext, exact h }

protected def id (X : endomorphisms C) : X ⟶ X :=
{ f := 𝟙 _,
  comm := by rw [category.comp_id, category.id_comp] }

protected def comp {X Y Z : endomorphisms C} (f : X ⟶ Y) (g : Y ⟶ Z) : X ⟶ Z :=
{ f := f.f ≫ g.f,
  comm := by simp only [hom.comm, hom.comm_assoc, category.assoc] }

instance (C : Type u) [category.{v} C] : category_struct (endomorphisms C) :=
{ id := λ X, X.id,
  comp := λ X Y Z f g, endomorphisms.comp f g }

@[simp] lemma id_f (X : endomorphisms C) : hom.f (𝟙 X) = 𝟙 X.X := rfl

@[simps]
def end_of_e (X : endomorphisms C) : X ⟶ X := ⟨X.e, rfl⟩

lemma end_of_e_comm {X Y : endomorphisms C} (g : X ⟶ Y) : X.end_of_e ≫ g =
  g ≫ Y.end_of_e :=
by { ext, apply endomorphisms.hom.comm, }

@[simp, reassoc] lemma comp_f {X Y Z : endomorphisms C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  hom.f (f ≫ g) = f.f ≫ g.f := rfl

instance (C : Type u) [category.{v} C] : category (endomorphisms C) :=
{ id_comp' := λ X Y f, by { ext1, simp only [comp_f, id_f, category.id_comp] },
  comp_id' := λ X Y f, by { ext1, simp only [comp_f, id_f, category.comp_id] },
  assoc' := λ X Y Z W f g h, by { ext1, simp only [comp_f, category.assoc] } }

lemma congr_f {X Y : endomorphisms C} (f₁ f₂ : X ⟶ Y) (h : f₁ = f₂) : f₁.f = f₂.f := by rw h

@[simp, reassoc] lemma pow_comm {X Y : endomorphisms C} (f : X ⟶ Y) (n : ℕ) :
  (X.e ^ n : End X.X) ≫ f.f = f.f ≫ (Y.e ^ n : End Y.X) :=
begin
  induction n with n ih,
  { simp only [pow_zero, End.one_def, category.id_comp, category.comp_id] },
  { simp only [nat.succ_eq_add_one, pow_succ, End.mul_def, category.assoc, hom.comm, reassoc_of ih] }
end

@[simps]
protected def forget (C : Type u) [category.{v} C] : endomorphisms C ⥤ C :=
{ obj := λ X, X.X,
  map := λ X Y f, f.f,
  map_id' := λ X, rfl,
  map_comp' := λ X Y Z f g, rfl }

instance forget_faithful : faithful (endomorphisms.forget C) :=
{ map_injective' := by { intros X Y f g h, ext, exact h } }

lemma epi_of_epi_f {X Y : endomorphisms C} (f : X ⟶ Y) [epi f.f] : epi f :=
{ left_cancellation := λ Z g h w, begin
    ext, rw [← cancel_epi f.f, ← comp_f, w, comp_f],
  end }

def mk_iso {X Y : endomorphisms C} (e : X.X ≅ Y.X) (h : X.e ≫ e.hom = e.hom ≫ Y.e) : X ≅ Y :=
{ hom := ⟨e.hom, h⟩,
  inv := ⟨e.inv, by rw [e.comp_inv_eq, category.assoc, e.eq_inv_comp, h]⟩,
  hom_inv_id' := by { ext, simp only [comp_f, iso.hom_inv_id, id_f] },
  inv_hom_id' := by { ext, simp only [comp_f, iso.inv_hom_id, id_f] } }

end category

section limits

variables {C : Type u} [category.{v} C]
variables {J : Type v'} [small_category J]

@[simps]
def twist_cone {K : J ⥤ endomorphisms C}
  (S : cone (K ⋙ endomorphisms.forget C)) :
  cone (K ⋙ endomorphisms.forget C) :=
{ X := S.X,
  π :=
  { app := λ j, S.π.app j ≫ (K.obj j).e,
    naturality' := begin
      intros i j f,
      dsimp,
      simp only [category.id_comp, category.assoc, hom.comm],
      erw S.w_assoc,
    end } }

abbreviation cone_e {K : J ⥤ endomorphisms C}
  (S : cone (K ⋙ endomorphisms.forget C)) (hS : is_limit S) :
  S.X ⟶ S.X :=
@is_limit.lift J _ C _ (K ⋙ endomorphisms.forget C) S hS (twist_cone S)

@[simps]
protected def cone {K : J ⥤ endomorphisms C}
  (S : cone (K ⋙ endomorphisms.forget C)) (hS : is_limit S) :
  cone K :=
{ X :=
  { X := S.X,
    e := cone_e S hS },
  π :=
  { app := λ j,
    { f := S.π.app _,
      comm := by { dsimp, simp } },
    naturality' := λ i j f, begin
      ext, dsimp, simp, erw S.w,
    end } }

@[simps]
protected def is_limit_cone {K : J ⥤ endomorphisms C}
  (S : cone (K ⋙ endomorphisms.forget C)) (hS : is_limit S) :
  is_limit (endomorphisms.cone S hS) :=
{ lift := λ S,
  { f := hS.lift ⟨S.X.X,
    { app := λ j, (S.π.app _).f,
      naturality' := begin
        intros i j f,
        dsimp,
        simp [← comp_f],
      end }⟩,
    comm := begin
      apply hS.hom_ext, dsimp, simp,
    end },
  fac' := begin
    intros s j, ext, dsimp, simp,
  end,
  uniq' := begin
    intros s m hm, ext, apply hS.hom_ext,
    intros j, specialize hm j, apply_fun (λ e, e.f) at hm,
    dsimp at *, simp [hm],
  end }

.

protected def cone_iso {K : J ⥤ endomorphisms C} (S : cone K)
  (hS : is_limit ((endomorphisms.forget C).map_cone S)) :
  endomorphisms.cone _ hS ≅ S :=
cones.ext
({ hom :=
  { f := 𝟙 _,
    comm := by { apply hS.hom_ext, intros j, dsimp, simp, erw hS.fac, dsimp, simp, } },
  inv :=
  { f := 𝟙 _,
    comm := by { apply hS.hom_ext, intros j, dsimp, simp, erw hS.fac, dsimp, simp } },
  hom_inv_id' := by { ext, dsimp, simp },
  inv_hom_id' := by { ext, dsimp, simp } })
begin
  intros j, ext,
  dsimp, simp,
end

protected def cone_iso' {K : J ⥤ endomorphisms C}
  (S : cone (K ⋙ endomorphisms.forget C)) (hS : is_limit S) :
  (endomorphisms.forget C).map_cone (endomorphisms.cone S hS) ≅ S :=
cones.ext
(iso.refl _)
begin
  intros j,
  dsimp,
  simp,
end

instance has_limit (K : J ⥤ endomorphisms C) [has_limit (K ⋙ endomorphisms.forget C)] :
  has_limit K :=
⟨⟨⟨_, endomorphisms.is_limit_cone _ (limit.is_limit _)⟩⟩⟩

instance has_limits_of_shape [has_limits_of_shape J C] :
  has_limits_of_shape J (endomorphisms C) := ⟨⟩

instance has_limits [has_limits C] : has_limits (endomorphisms C) := ⟨⟩

instance creates_limit (K : J ⥤ endomorphisms C) : creates_limit K (endomorphisms.forget _) :=
{ reflects := λ S hS, is_limit.of_iso_limit (endomorphisms.is_limit_cone _ _)
    (endomorphisms.cone_iso _ hS),
  lifts := λ S hS,
  { lifted_cone := endomorphisms.cone _ hS,
    valid_lift := endomorphisms.cone_iso' _ _ } }

instance preserves_limit (K : J ⥤ endomorphisms C) [has_limit (K ⋙ endomorphisms.forget C)] :
  preserves_limit K (endomorphisms.forget C) :=
category_theory.preserves_limit_of_creates_limit_and_has_limit K (endomorphisms.forget C)

instance preserves_limits_of_shape [has_limits_of_shape J C] :
  preserves_limits_of_shape J (endomorphisms.forget C) := ⟨⟩

instance preserves_limits [has_limits C] : preserves_limits (endomorphisms.forget C) := ⟨⟩

instance [has_finite_limits C] : preserves_finite_limits (endomorphisms.forget C) :=
begin
  apply preserves_finite_limits_of_preserves_finite_limits_of_size.{v},
  introsI J hJ1 hJ2, apply_instance,
end

end limits

section colimits

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

@[simps]
def twist_cocone {K : J ⥤ endomorphisms C}
  (S : cocone (K ⋙ endomorphisms.forget C)) :
  cocone (K ⋙ endomorphisms.forget C) :=
{ X := S.X,
  ι :=
  { app := λ j, (K.obj j).e ≫ S.ι.app j,
    naturality' := begin
      intros i j f,
      dsimp,
      simp only [category.comp_id, ← hom.comm_assoc],
      erw S.w,
    end } }

abbreviation cocone_e {K : J ⥤ endomorphisms C}
  (S : cocone (K ⋙ endomorphisms.forget C)) (hS : is_colimit S) :
  S.X ⟶ S.X :=
@is_colimit.desc J _ C _ (K ⋙ endomorphisms.forget C) S hS (twist_cocone S)

@[simps]
protected def cocone {K : J ⥤ endomorphisms C}
  (S : cocone (K ⋙ endomorphisms.forget C)) (hS : is_colimit S) :
  cocone K :=
{ X :=
  { X := S.X,
    e := cocone_e S hS },
  ι :=
  { app := λ j,
    { f := S.ι.app j,
      comm := by { dsimp, simp } },
    naturality' := λ i j f, begin
      ext, dsimp, simp, erw S.w,
    end } }

@[simps]
protected def is_colimit_cocone {K : J ⥤ endomorphisms C}
  (S : cocone (K ⋙ endomorphisms.forget C)) (hS : is_colimit S) :
  is_colimit (endomorphisms.cocone S hS) :=
{ desc := λ S,
  { f := hS.desc ⟨S.X.X,
    { app := λ j, (S.ι.app j).f,
      naturality' := begin
        intros i j f,
        dsimp,
        simp [← comp_f],
      end }⟩,
    comm := begin
      apply hS.hom_ext, dsimp, simp,
    end },
  fac' := begin
    intros s j, ext, dsimp, simp,
  end,
  uniq' := begin
    intros s m hm, ext, apply hS.hom_ext,
    intros j, specialize hm j, apply_fun (λ e, e.f) at hm,
    dsimp at *, simp [hm],
  end }

.

protected def cocone_iso {K : J ⥤ endomorphisms C} (S : cocone K)
  (hS : is_colimit ((endomorphisms.forget C).map_cocone S)) :
  endomorphisms.cocone _ hS ≅ S :=
cocones.ext
({ hom :=
  { f := 𝟙 _,
    comm := by { apply hS.hom_ext, intros j, dsimp, simp, erw hS.fac, dsimp, simp, } },
  inv :=
  { f := 𝟙 _,
    comm := by { apply hS.hom_ext, intros j, dsimp, simp, erw hS.fac, dsimp, simp } },
  hom_inv_id' := by { ext, dsimp, simp },
  inv_hom_id' := by { ext, dsimp, simp } })
begin
  intros j, ext,
  dsimp, simp,
end

protected def cocone_iso' {K : J ⥤ endomorphisms C}
  (S : cocone (K ⋙ endomorphisms.forget C)) (hS : is_colimit S) :
  (endomorphisms.forget C).map_cocone (endomorphisms.cocone S hS) ≅ S :=
cocones.ext
(iso.refl _)
begin
  intros j,
  dsimp,
  simp,
end

instance has_colimit (K : J ⥤ endomorphisms C) [has_colimit (K ⋙ endomorphisms.forget C)] :
  has_colimit K :=
⟨⟨⟨_, endomorphisms.is_colimit_cocone _ (colimit.is_colimit _)⟩⟩⟩

instance has_colimits_of_shape [has_colimits_of_shape J C] :
  has_colimits_of_shape J (endomorphisms C) := ⟨⟩

instance has_colimits [has_colimits C] : has_colimits (endomorphisms C) := ⟨⟩

instance creates_colimit (K : J ⥤ endomorphisms C) : creates_colimit K (endomorphisms.forget _) :=
{ reflects := λ S hS, is_colimit.of_iso_colimit (endomorphisms.is_colimit_cocone _ _)
    (endomorphisms.cocone_iso _ hS),
  lifts := λ S hS,
  { lifted_cocone := endomorphisms.cocone _ hS,
    valid_lift := endomorphisms.cocone_iso' _ _ } }

instance preserves_colimit (K : J ⥤ endomorphisms C) [has_colimit (K ⋙ endomorphisms.forget C)] :
  preserves_colimit K (endomorphisms.forget C) :=
category_theory.preserves_colimit_of_creates_colimit_and_has_colimit K (endomorphisms.forget C)

instance preserves_colimits_of_shape [has_colimits_of_shape J C] :
  preserves_colimits_of_shape J (endomorphisms.forget C) := ⟨⟩

instance preserves_colimits [has_colimits C] : preserves_colimits (endomorphisms.forget C) := ⟨⟩

instance [has_finite_colimits C] : preserves_finite_colimits (endomorphisms.forget C) :=
begin
  apply preserves_finite_colimits_of_preserves_finite_colimits_of_size.{v},
  introsI J hJ1 hJ2, apply_instance,
end

end colimits

section projectives

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

section free

variable [has_coproducts_of_shape (ulift.{v} ℕ) C]

/-- `free X` is ⨁ₙX, the direct sum over the naturals, equipped with the endomorphism
sending `(a : X)` in degree `n` to `a` in degree `n+1`. An alternative way to view `free X`
is `X ⨂_{ℤ} ℤ[T]` with the endomorphism given by multiplication by `T`. -/
@[simps]
def free (X : C) : endomorphisms C :=
{ X := ∐ (λ i : ulift.{v} ℕ, X),
  e := sigma.desc $ λ i, sigma.ι (λ i : ulift.{v} ℕ, X) ⟨i.down + 1⟩ }

@[reassoc] lemma free.ι_comp_e (X : C) (i : ulift.{v} ℕ) :
  sigma.ι (λ i : ulift.{v} ℕ, X) i ≫ (free X).e = sigma.ι (λ i : ulift.{v} ℕ, X) ⟨i.down + 1⟩ :=
begin
  dsimp, simp only [colimit.ι_desc, cofan.mk_ι_app],
end

@[ext] lemma free.ext {X : C} {A : endomorphisms C} (f g : free X ⟶ A)
  (w : sigma.ι (λ i : ulift.{v} ℕ, X) ⟨0⟩ ≫ f.f = sigma.ι (λ i : ulift.{v} ℕ, X) ⟨0⟩ ≫ g.f) :
  f = g :=
begin
  ext ⟨⟨i⟩⟩, dsimp,
  induction i with i ih, { exact w },
  apply_fun (λ α, α ≫ A.e) at ih,
  simp only [category.assoc, ← hom.comm, free.ι_comp_e_assoc] at ih,
  exact ih,
end

/-- The map `free T ⟶ A` in `endomorphisms C` induced by a map `T ⟶ A.X` in `C`. Here `A.X`
is the forgetful functor forgetting the endomorphism. -/
@[simps]
def free.desc {X : C} {A : endomorphisms C} (f : X ⟶ A.X) : free X ⟶ A :=
{ f := sigma.desc $ λ i, f ≫ (A.e ^ i.down : End A.X),
  comm := begin
    ext1 ⟨i⟩, dsimp,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app,
      colimit.ι_desc, category.assoc, pow_succ, End.mul_def],
  end }

lemma free.desc_comp {X : C} {A B : endomorphisms C} (f : X ⟶ A.X) (g : A ⟶ B) :
  free.desc f ≫ g = free.desc (f ≫ g.f) :=
begin
  ext1, dsimp,
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc, category.assoc, pow_comm],
end

def free.map {X Y : C} (f : X ⟶ Y) : free X ⟶ free Y :=
{ f := sigma.desc $ λ i, f ≫ sigma.ι (λ i : ulift.{v} ℕ, Y) i,
  comm := begin
    ext1 ⟨i⟩,
    dsimp,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc, category.assoc],
  end }

variable (C)

def functor.free : C ⥤ endomorphisms C :=
{ obj := free,
  map := λ _ _, free.map,
  map_id' := λ X, begin ext, dsimp, simp only [free.map, category.id_comp, colimit.ι_desc,
    cofan.mk_ι_app, category.comp_id], end,
  map_comp' := λ X Y Z f g, begin ext, dsimp, simp only [free.map, category.assoc, colimit.ι_desc,
    cofan.mk_ι_app, colimit.ι_desc_assoc], end }

end free

section cofree

variable {C}
variable [has_products_of_shape (ulift.{v} ℕ) C]

/-- `cofree X` is ∏ₙX, the product over the naturals, equipped with the endomorphism
sending `(a : X)` in degree `n` to `a` in degree `n+1`. -/
def cofree (X : C) : endomorphisms C :=
{ X := ∏ (λ i : ulift.{v} ℕ, X),
  e := pi.lift $ λ i, pi.π _ ⟨i.down + 1⟩ }

def cofree.lift {X : C} {A : endomorphisms C} (f : A.X ⟶ X) :
  A ⟶ cofree X :=
{ f := pi.lift $ λ i, (A.e ^ i.down : End A.X) ≫ f,
  comm := begin
    dsimp [cofree],
    ext ⟨⟨j⟩⟩, dsimp,
    simp only [category.assoc, limit.lift_π, fan.mk_π_app],
    rw [← category.assoc, pow_succ, ← End.mul_def], congr' 1,
    induction j with j hj,
    { simp },
    { simp only [End.mul_def, pow_succ] at *,
      simp [reassoc_of hj] }
  end }

end cofree

variables [has_products_of_shape (ulift.{v} ℕ) C] [has_coproducts_of_shape (ulift.{v} ℕ) C]

lemma f_epi {X Y : endomorphisms C} (f : X ⟶ Y) [epi f] : epi f.f :=
{ left_cancellation := λ Z g h w, begin
    let gg : Y ⟶ cofree Z := cofree.lift g,
    let hh : Y ⟶ cofree Z := cofree.lift h,
    have : f ≫ gg = f ≫ hh,
    { ext, dsimp [gg, hh, cofree.lift], simp,
      simp_rw [← category.assoc, ← pow_comm, category.assoc, w] },
    rw cancel_epi at this,
    apply_fun (λ e, e.f ≫ pi.π (λ i : ulift.{v} ℕ, Z) (ulift.up 0)) at this,
    dsimp [gg, hh, cofree.lift] at this, simpa using this,
  end }

lemma f_mono {X Y : endomorphisms C} (f : X ⟶ Y) [mono f] : mono f.f :=
{ right_cancellation := λ Z g h w, begin
    let gg : free Z ⟶ X := free.desc g,
    let hh : free Z ⟶ X := free.desc h,
    have : gg ≫ f = hh ≫ f,
    { ext, dsimp [gg,hh, free.desc], simpa },
    rw cancel_mono at this,
    apply_fun (λ e, sigma.ι ((λ i : ulift.{v} ℕ, Z)) (ulift.up 0) ≫ e.f) at this,
    dsimp [gg, hh, free.desc] at this, simpa using this
  end }

instance free.projective (X : C) [projective X] : projective (free X) :=
{ factors := λ E Y f e he, begin
    resetI,
    let φ : X ⟶ Y.X := sigma.ι (λ i : ulift.{v} ℕ, X) ⟨0⟩ ≫ f.f,
    haveI : epi e.f := f_epi _,
    use free.desc (projective.factor_thru φ e.f),
    rw [free.desc_comp, projective.factor_thru_comp],
    ext1, dsimp, simp only [colimit.ι_desc, cofan.mk_ι_app, pow_zero, End.one_def, category.comp_id],
  end }

def free.presentation [enough_projectives C] (A : endomorphisms C) :
  projective_presentation A :=
{ P := free (projective.over A.X),
  projective := infer_instance,
  f := free.desc $ projective.π _,
  epi := begin
    suffices : epi (free.desc (projective.π A.X)).f,
    { resetI, apply epi_of_epi_f },
    dsimp,
    refine @epi_of_epi _ _ _ _ _ (sigma.ι _ _) _ (id _), { exact ⟨0⟩ },
    simp only [colimit.ι_desc, cofan.mk_ι_app, pow_zero, End.one_def, category.comp_id],
    apply_instance
  end }

instance [enough_projectives C] : enough_projectives (endomorphisms C) :=
{ presentation := λ A, ⟨free.presentation A⟩ }

-- generalize to colimits
instance projective_sigma {C ι : Type*} [category C] (P : ι → C) [has_coproduct P]
  [∀ i, projective (P i)] :
  projective (∐ P) :=
{ factors := begin
  introsI E X f e he,
  let φ : ∐ P ⟶ E := sigma.desc (λ i, projective.factor_thru (sigma.ι _ _ ≫ f) e),
  refine ⟨φ, _⟩,
  ext ⟨i⟩,
  rw [limits.colimit.ι_desc_assoc, limits.cofan.mk_ι_app, projective.factor_thru_comp],
end }

instance projective_X [enough_projectives C] (P : endomorphisms C) [projective P] :
  projective P.X :=
⟨λ E X f e he, begin
  let F := free.presentation P,
  haveI : projective F.P.X := endomorphisms.projective_sigma _,
  haveI : epi F.f := F.epi,
  let s : P ⟶ F.P := projective.factor_thru (𝟙 _) F.f,
  have hsπ : s ≫ F.f = 𝟙 _ := projective.factor_thru_comp _ _,
  let X' : endomorphisms C := ⟨X, 𝟙 _⟩,
  let E' : endomorphisms C := ⟨E, 𝟙 _⟩,
  let e' : E' ⟶ X' := ⟨e, by { dsimp only, rw [category.id_comp, category.comp_id] }⟩,
  haveI he' : epi e' := epi_of_epi_f e',
  let φ : F.P.X ⟶ E := projective.factor_thru (F.f.f ≫ f) e,
  refine ⟨s.f ≫ φ, _⟩,
  rw [category.assoc, projective.factor_thru_comp, ← comp_f_assoc, hsπ, id_f, category.id_comp],
end⟩

end projectives

section preadditive
open category_theory.preadditive

variables {𝓐 : Type u} [category.{v} 𝓐] [preadditive 𝓐]
variables (X Y : endomorphisms 𝓐)

instance : has_zero (X ⟶ Y) := ⟨⟨0, by simp only [comp_zero, zero_comp, hom.comm]⟩⟩
instance : has_add (X ⟶ Y) := ⟨λ f g, ⟨f.f + g.f, by simp only [comp_add, add_comp, hom.comm]⟩⟩
instance : has_sub (X ⟶ Y) := ⟨λ f g, ⟨f.f - g.f, by simp only [comp_sub, sub_comp, hom.comm]⟩⟩
instance : has_neg (X ⟶ Y) := ⟨λ f, ⟨-f.f, by simp only [comp_neg, neg_comp, hom.comm]⟩⟩
instance has_nsmul : has_smul ℕ (X ⟶ Y) := ⟨λ n f, ⟨n • f.f, by simp only [comp_nsmul, nsmul_comp, hom.comm]⟩⟩
instance has_zsmul : has_smul ℤ (X ⟶ Y) := ⟨λ n f, ⟨n • f.f, by simp only [comp_zsmul, zsmul_comp, hom.comm]⟩⟩

instance : add_comm_group (X ⟶ Y) :=
(f_injective X Y).add_comm_group _ rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

@[simp] lemma zero_f : hom.f (0 : X ⟶ Y) = 0 := rfl
variables {X Y} (f g : X ⟶ Y)
@[simp] lemma add_f : (f + g).f = f.f + g.f := rfl
@[simp] lemma sub_f : (f - g).f = f.f - g.f := rfl
@[simp] lemma neg_f : (-f).f = -(f.f) := rfl
@[simp] lemma nsmul_f (n : ℕ) (f : X ⟶ Y) : (n • f).f = n • f.f := rfl
@[simp] lemma zsmul_f (n : ℤ) (f : X ⟶ Y) : (n • f).f = n • f.f := rfl

variables (𝓐)

instance : preadditive (endomorphisms 𝓐) :=
{ add_comp' := by { intros, ext, dsimp, rw add_comp },
  comp_add' := by { intros, ext, dsimp, rw comp_add } }

instance forget_additive : (endomorphisms.forget 𝓐).additive := {}

instance functor.free_additive [has_coproducts_of_shape (ulift.{v} ℕ) 𝓐] :
  (functor.free 𝓐).additive := ⟨λ X Y f g, by { delta functor.free free.map,
    ext, simp, }⟩

lemma is_zero_X {X : endomorphisms 𝓐} (h : is_zero X) : is_zero X.X :=
by { rw is_zero_iff_id_eq_zero at h ⊢, apply_fun (λ a, a.f) at h, exact h }

end preadditive

section abelian

variables {𝓐 : Type u} [category.{v} 𝓐] [abelian 𝓐]
  {X Y : endomorphisms 𝓐} (f : X ⟶ Y)

@[simps]
protected def kernel_obj : endomorphisms 𝓐 :=
{ X := kernel f.f,
  e := kernel.lift _ (kernel.ι _ ≫ X.e) (by simp) }

@[simps]
protected def kernel_ι : endomorphisms.kernel_obj f ⟶ X :=
{ f := kernel.ι _,
  comm := by { dsimp, simp } }

protected def kernel_fork : kernel_fork f :=
kernel_fork.of_ι (endomorphisms.kernel_ι f) $ by { ext, dsimp, simp }

@[simp]
protected lemma kernel_fork_ι_f :
  (endomorphisms.kernel_fork f).ι.f = kernel.ι _ := rfl

@[simps]
protected def kernel_lift (s : kernel_fork f) :
  s.X ⟶ endomorphisms.kernel_obj f :=
{ f := kernel.lift _ s.ι.f $ by { rw [← comp_f, s.condition, zero_f], },
  comm := by { ext, dsimp, simp } }

@[simps]
protected def is_limit_kernel_fork : is_limit (endomorphisms.kernel_fork f) :=
is_limit_aux _
(λ s, endomorphisms.kernel_lift f s)
(λ s, by { ext, dsimp, simp })
(λ s m hm, by { apply_fun (λ e, e.f) at hm, ext, dsimp at *, simp [hm] } )

instance has_kernels : has_kernels (endomorphisms 𝓐) :=
⟨λ X Y f, ⟨⟨⟨endomorphisms.kernel_fork _, endomorphisms.is_limit_kernel_fork _⟩⟩⟩⟩

@[simps]
protected def cokernel_obj : endomorphisms 𝓐 :=
{ X := cokernel f.f,
  e := cokernel.desc _ (Y.e ≫ cokernel.π _) $
    by { simp only [← (reassoc_of f.comm), cokernel.condition, comp_zero] } }

@[simps]
protected def cokernel_π : Y ⟶ endomorphisms.cokernel_obj f :=
{ f := cokernel.π _,
  comm := by simp }

protected def cokernel_cofork : cokernel_cofork f :=
cokernel_cofork.of_π (endomorphisms.cokernel_π f) $ by { ext, dsimp, simp }

@[simp]
protected lemma cokernel_cofork_π_f :
  (endomorphisms.cokernel_cofork f).π.f = cokernel.π _ := rfl

@[simps]
protected def cokernel_desc (s : cokernel_cofork f) :
  endomorphisms.cokernel_obj f ⟶ s.X :=
{ f := cokernel.desc _ s.π.f $ by { rw [← comp_f, s.condition, zero_f] },
  comm := by { ext, dsimp, simp } }

@[simps]
protected def is_colimit_cokernel_cofork : is_colimit (endomorphisms.cokernel_cofork f) :=
is_colimit_aux _
(λ s, endomorphisms.cokernel_desc f s)
(λ s, by { ext, dsimp, simp })
(λ s m hm, by { apply_fun (λ e, e.f) at hm, ext, dsimp at *, simp [hm] })

instance has_cokernels : has_cokernels (endomorphisms 𝓐) :=
⟨λ X Y f, ⟨⟨⟨endomorphisms.cokernel_cofork _, endomorphisms.is_colimit_cokernel_cofork _⟩⟩⟩⟩

def kernel_fork_iso :
  endomorphisms.kernel_fork f ≅ kernel_fork.of_ι (endomorphisms.kernel_ι f)
  (endomorphisms.kernel_fork f).condition :=
cones.ext
(iso.refl _)
(by { rintro (_|_); tidy })

def is_limit_fork_of_is_limit
  (hF : is_limit (limits.kernel_fork.of_ι f.f (cokernel.condition _))) :
  is_limit (limits.kernel_fork.of_ι f (endomorphisms.cokernel_cofork _).condition) :=
is_limit_aux _
(λ S,
{ f := hF.lift (kernel_fork.of_ι S.ι.f begin
    change _ ≫ (endomorphisms.cokernel_cofork _).π.f = _,
    erw [← comp_f, S.condition, zero_f],
  end),
  comm := begin
    apply hF.hom_ext, rintro (_|_),
    { dsimp, simp only [category.assoc, hom.comm], erw hF.fac _ (walking_parallel_pair.zero),
      erw hF.fac_assoc _ (walking_parallel_pair.zero),
      dsimp, simp, },
    { dsimp, simp, }
  end })
begin
  intros S,
  ext, dsimp, erw hF.fac _ walking_parallel_pair.zero, refl,
end
begin
  intros S m hm,
  ext, dsimp, apply hF.hom_ext, rintros (_|_),
  { apply_fun (λ e, e.f) at hm,
    dsimp at *,
    simp only [hm],
    erw hF.fac _ (walking_parallel_pair.zero), refl },
  { dsimp, simp },
end

def is_colimit_cofork_of_is_colimit
  (hF : is_colimit (limits.cokernel_cofork.of_π f.f (kernel.condition _))) :
  is_colimit (limits.cokernel_cofork.of_π f (endomorphisms.kernel_fork _).condition) :=
is_colimit_aux _
(λ S,
{ f := hF.desc (cokernel_cofork.of_π S.π.f begin
    change (endomorphisms.kernel_fork _).ι.f ≫ _ = _,
    erw [← comp_f, S.condition, zero_f]
  end),
  comm := begin
    apply hF.hom_ext, rintro (_|_),
    { dsimp, simp },
    { dsimp, erw hF.fac_assoc _ (walking_parallel_pair.one),
      rw [← hom.comm_assoc],
      erw hF.fac _ (walking_parallel_pair.one),
      dsimp, simp }
  end })
begin
  intros S,
  ext, dsimp, erw hF.fac _ walking_parallel_pair.one, refl,
end
begin
  intros S m hm,
  ext, dsimp, apply hF.hom_ext, rintros (_|_),
  { dsimp, simp },
  { apply_fun (λ e, e.f) at hm,
    dsimp at *,
    simp only [hm],
    erw hF.fac _ walking_parallel_pair.one, refl }
end

instance [has_coproducts_of_shape (ulift.{v} ℕ) 𝓐] [has_products_of_shape (ulift.{v} ℕ) 𝓐] :
  abelian (endomorphisms 𝓐) :=
{ normal_mono_of_mono := begin
    introsI X Y f _,
    haveI := f_mono f,
    let hE : is_limit (kernel_fork.of_ι f.f _) :=
      category_theory.abelian.mono_is_kernel_of_cokernel _ (colimit.is_colimit _),
    fconstructor,
    exact endomorphisms.cokernel_obj f,
    exact endomorphisms.cokernel_π f,
    exact (endomorphisms.cokernel_cofork f).condition,
    apply is_limit_fork_of_is_limit _ hE,
  end,
  normal_epi_of_epi := begin
    introsI X Y f _,
    haveI := f_epi f,
    let hE : is_colimit (cokernel_cofork.of_π f.f _) :=
      category_theory.abelian.epi_is_cokernel_of_kernel _ (limit.is_limit _),
    fconstructor,
    exact endomorphisms.kernel_obj f,
    exact endomorphisms.kernel_ι f,
    exact (endomorphisms.kernel_fork f).condition,
    apply is_colimit_cofork_of_is_colimit _ hE,
  end,
  has_finite_products := begin
    constructor, intros J _,
    haveI : has_finite_products 𝓐 := abelian.has_finite_products, -- WHY IS THIS NEEDED!?
    constructor,
  end,
  .. (_ : preadditive (endomorphisms 𝓐)) }

end abelian

end endomorphisms

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 category_theory.monoidal.natural_transformation
import category_theory.monoidal.discrete

/-!
# Braided and symmetric monoidal categories

The basic definitions of braided monoidal categories, and symmetric monoidal categories,
as well as braided functors.

## Implementation note

We make `braided_monoidal_category` another typeclass, but then have `symmetric_monoidal_category`
extend this. The rationale is that we are not carrying any additional data,
just requiring a property.

## Future work

* Construct the Drinfeld center of a monoidal category as a braided monoidal category.
* Say something about pseudo-natural transformations.

-/

open category_theory

universes v v₁ v₂ v₃ u u₁ u₂ u₃

namespace category_theory

/--
A braided monoidal category is a monoidal category equipped with a braiding isomorphism
`β_ X Y : X ⊗ Y ≅ Y ⊗ X`
which is natural in both arguments,
and also satisfies the two hexagon identities.
-/
class braided_category (C : Type u) [category.{v} C] [monoidal_category.{v} C] :=
-- braiding natural iso:
(braiding             : Π X Y : C, X ⊗ Y ≅ Y ⊗ X)
(braiding_naturality' : ∀ {X X' Y Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y'),
  (f ⊗ g) ≫ (braiding Y Y').hom = (braiding X X').hom ≫ (g ⊗ f) . obviously)
-- hexagon identities:
(hexagon_forward'     : Π X Y Z : C,
    (α_ X Y Z).hom ≫ (braiding X (Y ⊗ Z)).hom ≫ (α_ Y Z X).hom
  = ((braiding X Y).hom ⊗ (𝟙 Z)) ≫ (α_ Y X Z).hom ≫ ((𝟙 Y) ⊗ (braiding X Z).hom)
  . obviously)
(hexagon_reverse'     : Π X Y Z : C,
    (α_ X Y Z).inv ≫ (braiding (X ⊗ Y) Z).hom ≫ (α_ Z X Y).inv
  = ((𝟙 X) ⊗ (braiding Y Z).hom) ≫ (α_ X Z Y).inv ≫ ((braiding X Z).hom ⊗ (𝟙 Y))
  . obviously)

restate_axiom braided_category.braiding_naturality'
attribute [simp,reassoc] braided_category.braiding_naturality
restate_axiom braided_category.hexagon_forward'
restate_axiom braided_category.hexagon_reverse'

open category
open monoidal_category
open braided_category

notation `β_` := braiding

section
/-!
We now establish how the braiding interacts with the unitors.

I couldn't find a detailed proof in print, but this is discussed in:

* Proposition 1 of André Joyal and Ross Street,
  "Braided monoidal categories", Macquarie Math Reports 860081 (1986).
* Proposition 2.1 of André Joyal and Ross Street,
  "Braided tensor categories" , Adv. Math. 102 (1993), 20–78.
* Exercise 8.1.6 of Etingof, Gelaki, Nikshych, Ostrik,
  "Tensor categories", vol 25, Mathematical Surveys and Monographs (2015), AMS.
-/

variables (C : Type u₁) [category.{v₁} C] [monoidal_category C] [braided_category C]

lemma braiding_left_unitor_aux₁ (X : C) :
  (α_ (𝟙_ C) (𝟙_ C) X).hom ≫ (𝟙 _ ⊗ (β_ X (𝟙_ C)).inv) ≫ (α_ _ X _).inv ≫ ((λ_ X).hom ⊗ 𝟙 _) =
  ((λ_ _).hom ⊗ 𝟙 X) ≫ (β_ X _).inv :=
by { rw [←left_unitor_tensor, left_unitor_naturality], simp, }

lemma braiding_left_unitor_aux₂ (X : C) :
  ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C))) = (ρ_ X).hom ⊗ (𝟙 (𝟙_ C)) :=
calc ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
    = ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ (α_ _ _ _).hom ≫ (α_ _ _ _).inv ≫
        ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by simp
... = ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (β_ X _).hom) ≫
        (𝟙 _ ⊗ (β_ X _).inv) ≫ (α_ _ _ _).inv ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by { slice_rhs 3 4 { rw [←id_tensor_comp, iso.hom_inv_id, tensor_id], }, rw [id_comp], }
... = (α_ _ _ _).hom ≫ (β_ _ _).hom ≫
        (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (β_ X _).inv) ≫ (α_ _ _ _).inv ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by { slice_lhs 1 3 { rw ←hexagon_forward }, simp only [assoc], }
... = (α_ _ _ _).hom ≫ (β_ _ _).hom ≫ ((λ_ _).hom ⊗ 𝟙 X) ≫ (β_ X _).inv
         : by rw braiding_left_unitor_aux₁
... = (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (λ_ _).hom) ≫ (β_ _ _).hom ≫ (β_ X _).inv
         : by { slice_lhs 2 3 { rw [←braiding_naturality] }, simp only [assoc], }
... = (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (λ_ _).hom)
         : by rw [iso.hom_inv_id, comp_id]
... = (ρ_ X).hom ⊗ (𝟙 (𝟙_ C))
         : by rw triangle

@[simp]
lemma braiding_left_unitor (X : C) : (β_ X (𝟙_ C)).hom ≫ (λ_ X).hom = (ρ_ X).hom :=
by rw [←tensor_right_iff, comp_tensor_id, braiding_left_unitor_aux₂]

lemma braiding_right_unitor_aux₁ (X : C) :
  (α_ X (𝟙_ C) (𝟙_ C)).inv ≫ ((β_ (𝟙_ C) X).inv ⊗ 𝟙 _) ≫ (α_ _ X _).hom ≫ (𝟙 _ ⊗ (ρ_ X).hom) =
  (𝟙 X ⊗ (ρ_ _).hom) ≫ (β_ _ X).inv :=
by { rw [←right_unitor_tensor, right_unitor_naturality], simp, }

lemma braiding_right_unitor_aux₂ (X : C) :
  ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom) = (𝟙 (𝟙_ C)) ⊗ (λ_ X).hom :=
calc ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
    = ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ (α_ _ _ _).inv ≫ (α_ _ _ _).hom ≫
        ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by simp
... = ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ (α_ _ _ _).inv ≫ ((β_ _ X).hom ⊗ 𝟙 _) ≫
        ((β_ _ X).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by { slice_rhs 3 4 { rw [←comp_tensor_id, iso.hom_inv_id, tensor_id], }, rw [id_comp], }
... = (α_ _ _ _).inv ≫ (β_ _ _).hom ≫
        (α_ _ _ _).inv ≫ ((β_ _ X).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by { slice_lhs 1 3 { rw ←hexagon_reverse }, simp only [assoc], }
... = (α_ _ _ _).inv ≫ (β_ _ _).hom ≫ (𝟙 X ⊗ (ρ_ _).hom) ≫ (β_ _ X).inv
         : by rw braiding_right_unitor_aux₁
... = (α_ _ _ _).inv ≫ ((ρ_ _).hom ⊗ 𝟙 _) ≫ (β_ _ X).hom ≫ (β_ _ _).inv
         : by { slice_lhs 2 3 { rw [←braiding_naturality] }, simp only [assoc], }
... = (α_ _ _ _).inv ≫ ((ρ_ _).hom ⊗ 𝟙 _)
         : by rw [iso.hom_inv_id, comp_id]
... = (𝟙 (𝟙_ C)) ⊗ (λ_ X).hom
         : by rw [triangle_assoc_comp_right]

@[simp]
lemma braiding_right_unitor (X : C) : (β_ (𝟙_ C) X).hom ≫ (ρ_ X).hom = (λ_ X).hom :=
by rw [←tensor_left_iff, id_tensor_comp, braiding_right_unitor_aux₂]

end

/--
A symmetric monoidal category is a braided monoidal category for which the braiding is symmetric.

See https://stacks.math.columbia.edu/tag/0FFW.
-/
class symmetric_category (C : Type u) [category.{v} C] [monoidal_category.{v} C]
   extends braided_category.{v} C :=
-- braiding symmetric:
(symmetry' : ∀ X Y : C, (β_ X Y).hom ≫ (β_ Y X).hom = 𝟙 (X ⊗ Y) . obviously)

restate_axiom symmetric_category.symmetry'
attribute [simp,reassoc] symmetric_category.symmetry

variables (C : Type u₁) [category.{v₁} C] [monoidal_category C] [braided_category C]
variables (D : Type u₂) [category.{v₂} D] [monoidal_category D] [braided_category D]
variables (E : Type u₃) [category.{v₃} E] [monoidal_category E] [braided_category E]

/--
A lax braided functor between braided monoidal categories is a lax monoidal functor
which preserves the braiding.
-/
structure lax_braided_functor extends lax_monoidal_functor C D :=
(braided' : ∀ X Y : C, μ X Y ≫ map (β_ X Y).hom = (β_ (obj X) (obj Y)).hom ≫ μ Y X . obviously)

restate_axiom lax_braided_functor.braided'

namespace lax_braided_functor

/-- The identity lax braided monoidal functor. -/
@[simps] def id : lax_braided_functor C C :=
{ .. monoidal_functor.id C }

instance : inhabited (lax_braided_functor C C) := ⟨id C⟩

variables {C D E}

/-- The composition of lax braided monoidal functors. -/
@[simps]
def comp (F : lax_braided_functor C D) (G : lax_braided_functor D E) : lax_braided_functor C E :=
{ braided' := λ X Y,
  begin
    dsimp,
    slice_lhs 2 3 { rw [←category_theory.functor.map_comp, F.braided,
      category_theory.functor.map_comp], },
    slice_lhs 1 2 { rw [G.braided], },
    simp only [category.assoc],
  end,
  ..(lax_monoidal_functor.comp F.to_lax_monoidal_functor G.to_lax_monoidal_functor) }

instance category_lax_braided_functor : category (lax_braided_functor C D) :=
induced_category.category lax_braided_functor.to_lax_monoidal_functor

@[simp] lemma comp_to_nat_trans {F G H : lax_braided_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

/--
Interpret a natural isomorphism of the underlyling lax monoidal functors as an
isomorphism of the lax braided monoidal functors.
-/
@[simps]
def mk_iso {F G : lax_braided_functor C D}
  (i : F.to_lax_monoidal_functor ≅ G.to_lax_monoidal_functor) : F ≅ G :=
{ ..i }

end lax_braided_functor

/--
A braided functor between braided monoidal categories is a monoidal functor
which preserves the braiding.
-/
structure braided_functor extends monoidal_functor C D :=
-- Note this is stated differently than for `lax_braided_functor`.
-- We move the `μ X Y` to the right hand side,
-- so that this makes a good `@[simp]` lemma.
(braided' :
  ∀ X Y : C, map (β_ X Y).hom = inv (μ X Y) ≫ (β_ (obj X) (obj Y)).hom ≫ μ Y X . obviously)

restate_axiom braided_functor.braided'
attribute [simp] braided_functor.braided

namespace braided_functor

/-- Turn a braided functor into a lax braided functor. -/
@[simps]
def to_lax_braided_functor (F : braided_functor C D) : lax_braided_functor C D :=
{ braided' := λ X Y, by { rw F.braided, simp, }
  .. F }

/-- The identity braided monoidal functor. -/
@[simps] def id : braided_functor C C :=
{ .. monoidal_functor.id C }

instance : inhabited (braided_functor C C) := ⟨id C⟩

variables {C D E}

/-- The composition of braided monoidal functors. -/
@[simps]
def comp (F : braided_functor C D) (G : braided_functor D E) : braided_functor C E :=
{ ..(monoidal_functor.comp F.to_monoidal_functor G.to_monoidal_functor) }

instance category_braided_functor : category (braided_functor C D) :=
induced_category.category braided_functor.to_monoidal_functor

@[simp] lemma comp_to_nat_trans {F G H : braided_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

/--
Interpret a natural isomorphism of the underlyling monoidal functors as an
isomorphism of the braided monoidal functors.
-/
@[simps]
def mk_iso {F G : braided_functor C D}
  (i : F.to_monoidal_functor ≅ G.to_monoidal_functor) : F ≅ G :=
{ ..i }

end braided_functor

section comm_monoid

variables (M : Type u) [comm_monoid M]

instance comm_monoid_discrete : comm_monoid (discrete M) := by { dsimp [discrete], apply_instance }

instance : braided_category (discrete M) :=
{ braiding := λ X Y, eq_to_iso (mul_comm X Y), }

variables {M} {N : Type u} [comm_monoid N]

/--
A multiplicative morphism between commutative monoids gives a braided functor between
the corresponding discrete braided monoidal categories.
-/
@[simps]
def discrete.braided_functor (F : M →* N) : braided_functor (discrete M) (discrete N) :=
{ ..discrete.monoidal_functor F }

end comm_monoid

end category_theory


/-
File: signature_recover_public_key_verify_zero_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
open tactic

open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.constants

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.cairo_secp.field.verify_zero autogenerated soundness theorem -/

theorem auto_sound_verify_zero
    -- arguments
    (range_check_ptr : F) (val : UnreducedBigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_verify_zero σ.pc)
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 6))
    (hin_val : val = cast_UnreducedBigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 11 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 6)) (mem $ τ.ap - 1)
        (spec_verify_zero mem κ range_check_ptr val (mem (τ.ap - 1)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_verify_zero at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13, hpc14, hpc15, hpc16, hpc17, hpc18, hpc19, hpc20, hpc21, hpc22⟩,
  -- let (ap reference)
  apply of_register_state,
  intros regstate_q regstateeq_q,
  generalize' hl_rev_q: mem regstate_q.ap = q,
  have hl_q := hl_rev_q.symm,
  rw [regstateeq_q] at hl_q, try { dsimp at hl_q },
  -- let (ap reference)
  apply of_register_state,
  intros regstate_q_biased regstateeq_q_biased,
  generalize' hl_rev_q_biased: mem (regstate_q_biased.ap + 1) = q_biased,
  have hl_q_biased := hl_rev_q_biased.symm,
  rw [regstateeq_q_biased] at hl_q_biased, try { dsimp at hl_q_biased },
  -- assert eq
  step_assert_eq hpc0 hpc1 with temp0,
  have a0: q_biased = q + 2 ^ 127, {
    apply assert_eq_reduction temp0,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased] },
    try { dsimp [cast_UnreducedBigInt3] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a0 }, try { arith_simps at a0 },
  clear temp0,
  -- assert eq
  step_assert_eq hpc2 with temp0,
  have a2: mem (range_check_ptr) = q_biased, {
    apply assert_eq_reduction temp0.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased] },
    try { dsimp [cast_UnreducedBigInt3] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a2 }, try { arith_simps at a2 },
  clear temp0,
  -- tempvar
  step_assert_eq hpc3 hpc4 with tv_r10,
  step_assert_eq hpc5 with tv_r11,
  step_assert_eq hpc6 hpc7 with tv_r12,
  generalize' hl_rev_r1: ((val.d0 + q * SECP_REM) / (BASE : ℤ) : F) = r1,
  have hl_r1 := hl_rev_r1.symm, clear hl_rev_r1,
  have htv_r1: r1 = _, {
    have h_δ3_c0 : ∀ x : F, x / (BASE : ℤ) = x * (-46768052394588894761721767695234645457402928824320 : ℤ),
    { intro x,  apply div_eq_mul_inv', apply PRIME.int_cast_mul_eq_one, rw [PRIME], try { simp_int_casts }, norm_num1 },
    apply eq.symm, apply eq.trans tv_r12,
      try { simp only [h_δ3_c0] at hl_r1 },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased, hl_r1] },
      try { dsimp [cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [tv_r10, tv_r11] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_r10 tv_r11 tv_r12,
  try { dsimp at hl_r1 }, try { arith_simps at hl_r1 },
  -- compound assert eq
  step_assert_eq hpc8 hpc9 with temp0,
  step_assert_eq hpc10 with temp1,
  have a8: mem (range_check_ptr + 1) = r1 + 2 ^ 127, {
    apply assert_eq_reduction temp1.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased, hl_r1, htv_r1] },
    try { dsimp [cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [temp0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a8 }, try { arith_simps at a8 },
  clear temp0 temp1,
  -- tempvar
  step_assert_eq hpc11 with tv_r20,
  step_assert_eq hpc12 hpc13 with tv_r21,
  generalize' hl_rev_r2: ((val.d1 + r1) / (BASE : ℤ) : F) = r2,
  have hl_r2 := hl_rev_r2.symm, clear hl_rev_r2,
  have htv_r2: r2 = _, {
    have h_δ11_c0 : ∀ x : F, x / (BASE : ℤ) = x * (-46768052394588894761721767695234645457402928824320 : ℤ),
    { intro x,  apply div_eq_mul_inv', apply PRIME.int_cast_mul_eq_one, rw [PRIME], try { simp_int_casts }, norm_num1 },
    apply eq.symm, apply eq.trans tv_r21,
      try { simp only [h_δ11_c0] at hl_r2 },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased, hl_r1, htv_r1, hl_r2] },
      try { dsimp [cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [tv_r20] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_r20 tv_r21,
  try { dsimp at hl_r2 }, try { arith_simps at hl_r2 },
  -- compound assert eq
  step_assert_eq hpc14 hpc15 with temp0,
  step_assert_eq hpc16 with temp1,
  have a14: mem (range_check_ptr + 2) = r2 + 2 ^ 127, {
    apply assert_eq_reduction temp1.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased, hl_r1, htv_r1, hl_r2, htv_r2] },
    try { dsimp [cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [temp0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a14 }, try { arith_simps at a14 },
  clear temp0 temp1,
  -- compound assert eq
  have h_δ17_c0 : ((BASE : ℤ) / (4 : ℤ) : F) = (19342813113834066795298816 : ℤ),
  { apply PRIME.div_eq_const,
    { apply PRIME.cast_ne_zero, norm_num1, rw [PRIME], try { simp_int_casts }, norm_num1 },
    rw [PRIME], try { simp_int_casts }, norm_num1 },
  step_assert_eq hpc17 hpc18 with temp0,
  step_assert_eq hpc19 with temp1,
  have a17: val.d2 = q * ((BASE : ℤ) / (4 : ℤ)) - r2, {
    try { simp only [h_δ17_c0] },
    apply assert_eq_reduction (eq_sub_of_eq_add temp1),
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased, hl_r1, htv_r1, hl_r2, htv_r2] },
    try { dsimp [cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [temp0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a17 }, try { arith_simps at a17 },
  clear temp0 temp1,
  -- let
  generalize' hl_rev_range_check_ptr₁: (range_check_ptr + 3 : F) = range_check_ptr₁,
  have hl_range_check_ptr₁ := hl_rev_range_check_ptr₁.symm, clear hl_rev_range_check_ptr₁,
  try { dsimp at hl_range_check_ptr₁ }, try { arith_simps at hl_range_check_ptr₁ },
  -- return
  step_assert_eq hpc20 hpc21 with hret0,
  step_ret hpc22,
  -- finish
  step_done, use_only [rfl, rfl],
  split, refl,
  -- range check condition
  use_only (3+0+0), split,
  linarith [],
  split,
  { arith_simps, try { simp only [hret0] },
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_verify_zero mem _ range_check_ptr val _,
  { apply sound_verify_zero, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_verify_zero],
  try { norm_num1 }, try { arith_simps },
  use_only [q],
  use_only [q_biased],
  use_only [a0],
  use_only [a2],
  cases rc_h_range_check_ptr' (0) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a2.symm, hin_range_check_ptr], arith_simps, exact hn },
  use_only [r1, hl_r1],
  use_only [a8],
  cases rc_h_range_check_ptr' (1) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a8.symm, hin_range_check_ptr], arith_simps, exact hn },
  use_only [r2, hl_r2],
  use_only [a14],
  cases rc_h_range_check_ptr' (2) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a14.symm, hin_range_check_ptr], arith_simps, exact hn },
  use_only [a17],
  have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
  have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁,try { norm_cast at rc_h_range_check_ptr₁' },
  use_only [range_check_ptr₁, hl_range_check_ptr₁],
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, hl_q, hl_q_biased, hl_r1, htv_r1, hl_r2, htv_r2, hl_range_check_ptr₁] }, },
  try { dsimp [cast_UnreducedBigInt3] },
  try { arith_simps }, try { simp only [hret0] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


import data.padics.padic_numbers

import for_mathlib.punit_instances

import perfectoid_space

/-!
# An example of a perfectoid space

In this file we show that the empty space is perfectoid.
Every nonempty example requires a non-trivial amount of mathematical effort.
-/

/-- The structure presheaf on the empty space. -/
def CLVRS.empty_presheaf : presheaf_of_topological_rings empty :=
{ F := λ _, unit,
  res := λ _ _ _ _, (),
  Hid := λ U, by {funext x, cases x, refl},
  Hcomp := λ U V W _ _, rfl,
  Fring := λ x, punit.comm_ring,
  res_is_ring_hom := λ U V _,
  { map_one := rfl,
    map_mul := λ  _ _, rfl,
    map_add := λ _ _, rfl },
  Ftop := λ U, by apply_instance,
  Ftop_ring := λ U, by apply_instance,
  res_continuous := λ U V _, continuous_of_discrete_topology }

/-- The structure sheaf on the empty space. -/
def CLVRS.empty_sheaf : sheaf_of_topological_rings empty :=
{ F := CLVRS.empty_presheaf,
  locality := by {rintro _ _ ⟨s⟩ ⟨t⟩ _, refl},
  gluing := by {intros _ _ c _, use (), intro i, cases c i, refl},
  homeo :=
  begin
    rintros ⟨U, HU⟩ ⟨γ, Uis, _⟩ c d,
    dsimp at *,
    change set unit at c,
    rcases subset_subsingleton c with rfl|rfl,
    { convert is_open_empty,
      exact set.image_empty _ },
    { convert is_open_univ,
      apply set.image_univ_of_surjective,
      rintro ⟨s, hs⟩,
      use (),
      apply subtype.eq,
      funext i,
      show () = s i,
      apply subsingleton.elim, },
  end }

/--The empty CLVRS-/
def CLVRS.empty : CLVRS := {
  space := empty,
  sheaf' := CLVRS.empty_sheaf,
  complete := λ U,
  { complete := λ f hf,
    begin
      use (),
      rintro V HV,
      convert f.univ_sets,
      funext x,
      cases x,
      show _ = true, rw eq_true,
      exact mem_of_nhds HV,
    end },
  valuation := by rintro ⟨⟩,
  local_stalks := by rintro ⟨⟩,
  supp_maximal := by rintro ⟨⟩ }

example : PerfectoidSpace ⟨37, by norm_num⟩ := ⟨CLVRS.empty, by rintro ⟨⟩⟩


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.rat.default
import Mathlib.data.semiquot
import Mathlib.PostPort

universes l u_1

namespace Mathlib

/-!
# Implementation of floating-point numbers (experimental).
-/

def int.shift2 (a : ℕ) (b : ℕ) : ℤ → ℕ × ℕ :=
  sorry

namespace fp

structure rmode
  NE ::
where

class float_cfg
where
  prec : ℕ
  emax : ℕ
  prec_pos : 0 < prec
  prec_max : prec ≤ emax

def prec [C : float_cfg] : ℕ :=
  float_cfg.prec

def emax [C : float_cfg] : ℕ :=
  float_cfg.emax

def emin [C : float_cfg] : ℤ :=
  1 - ↑float_cfg.emax

def valid_finite [C : float_cfg] (e : ℤ) (m : ℕ) :=
  emin ≤ e + ↑prec - 1 ∧ e + ↑prec - 1 ≤ ↑emax ∧ e = max (e + ↑(nat.size m) - ↑prec) emin

protected instance dec_valid_finite [C : float_cfg] (e : ℤ) (m : ℕ) : Decidable (valid_finite e m) :=
  eq.mpr sorry and.decidable

inductive float [C : float_cfg]
where
| inf : Bool → float
| nan : float
| finite : Bool → (e : ℤ) → (m : ℕ) → valid_finite e m → float

def float.is_finite [C : float_cfg] : float → Bool :=
  sorry

def to_rat [C : float_cfg] (f : float) : ↥(float.is_finite f) → ℚ :=
  sorry

theorem float.zero.valid [C : float_cfg] : valid_finite emin 0 := sorry

def float.zero [C : float_cfg] (s : Bool) : float :=
  float.finite s emin 0 sorry

protected instance float.inhabited [C : float_cfg] : Inhabited float :=
  { default := float.zero tt }

protected def float.sign' [C : float_cfg] : float → semiquot Bool :=
  sorry

protected def float.sign [C : float_cfg] : float → Bool :=
  sorry

protected def float.is_zero [C : float_cfg] : float → Bool :=
  sorry

protected def float.neg [C : float_cfg] : float → float :=
  sorry

def div_nat_lt_two_pow [C : float_cfg] (n : ℕ) (d : ℕ) : ℤ → Bool :=
  sorry

-- TODO(Mario): Prove these and drop 'meta'

namespace float

protected instance has_neg [C : float_cfg] : Neg float :=
  { neg := float.neg }


import algebraic_geometry.pullback_carrier
import for_mathlib.surjective_on_stalks
import algebraic_geometry.pushforward_stalk
import topology.local_at_target
import category_theory.morphism_property

open category_theory category_theory.limits topological_space opposite

namespace algebraic_geometry

universe u

noncomputable theory

variables {X Y Z : Scheme.{u}} (f : X ⟶ Z) (g : Y ⟶ Z)
variable (hg : ∀ y : Y.carrier, function.surjective (PresheafedSpace.stalk_map g.1 y))

@[simps apply_coe_fst apply_coe_snd]
def pullback_comparison :
  (pullback f g).carrier ⟶ Top.of (types.pullback_obj f.1.base g.1.base) :=
(Top.pullback_cone_is_limit f.1.base g.1.base).lift
  (pullback_cone.mk (pullback.fst : pullback f g ⟶ _).1.base
    (pullback.snd : pullback f g ⟶ _).1.base
    (by simp only [← Scheme.comp_val_base, pullback.condition]))

lemma pullback_comparison_comp_pullback_iso_prod_subtype_inv :
  pullback_comparison f g ≫ (Top.pullback_iso_prod_subtype f.1.base g.1.base).inv =
  category_theory.limits.pullback_comparison Scheme.forget_to_Top f g :=
begin
  apply pullback.hom_ext; simp only [pullback_comparison, category.assoc,
    Top.pullback_iso_prod_subtype_inv_fst, Top.pullback_iso_prod_subtype_inv_snd,
      pullback_comparison_comp_fst, pullback_comparison_comp_snd],
  exacts [(Top.pullback_cone_is_limit f.1.base g.1.base).fac _ walking_cospan.left,
    (Top.pullback_cone_is_limit f.1.base g.1.base).fac _ walking_cospan.right]
end

-- move me
@[simps]
def pullback.triplet_mk {X Y Z : Scheme} (f : X ⟶ Z) (g : Y ⟶ Z) (x : X.carrier) (y : Y.carrier)
  (h : f.1.base x = g.1.base y) : pullback.triplet f g :=
⟨x, y, _, h, rfl⟩

lemma is_open_immersion.base_open [is_open_immersion f] : open_embedding f.1.base :=
PresheafedSpace.is_open_immersion.base_open

lemma Scheme.Spec_map_val_base {R S : CommRing} (f : R ⟶ S) :
  (Scheme.Spec.map f.op).1.base = prime_spectrum.comap f := rfl

section open_cover

-- move me
/-- The coordinate ring of a component in the `affine_cover`. -/
def Scheme.affine_cover_ring (X : Scheme) (i : X.affine_cover.J) : CommRing :=
CommRing.of $ (X.local_affine i).some_spec.some

-- move me
lemma Scheme.affine_cover_obj (X : Scheme) (i : X.affine_cover.J) :
  X.affine_cover.obj i = Scheme.Spec.obj (op $ X.affine_cover_ring i) := rfl

-- local attribute [irreducible] Scheme.affine_cover

def pullback_affine_cover : Scheme.open_cover.{u} (pullback f g) :=
  (Scheme.pullback.open_cover_of_base.{u u u} Z.affine_cover f g).bind
    (λ i, Scheme.pullback.open_cover_of_left_right.{u u u u}
      (pullback f (Z.affine_cover.map i)).affine_cover
      (pullback g (Z.affine_cover.map i)).affine_cover pullback.snd pullback.snd)

variable (i : (pullback_affine_cover f g).J)

def pullback_affine_cover_ring_left : CommRing :=
Scheme.affine_cover_ring _ i.2.1

def pullback_affine_cover_ring_right : CommRing :=
Scheme.affine_cover_ring _ i.2.2

def pullback_affine_cover_ring_base : CommRing :=
Scheme.affine_cover_ring _ i.1

@[derive is_open_immersion]
def pullback_affine_cover_map_left :
  Scheme.Spec.obj (op $ pullback_affine_cover_ring_left f g i) ⟶ X :=
(pullback f (Z.affine_cover.map i.1)).affine_cover.map i.2.1 ≫ pullback.fst

@[derive is_open_immersion]
def pullback_affine_cover_map_right :
  Scheme.Spec.obj (op $ pullback_affine_cover_ring_right f g i) ⟶ Y :=
(pullback g (Z.affine_cover.map i.1)).affine_cover.map i.2.2 ≫ pullback.fst

@[derive is_open_immersion]
def pullback_affine_cover_map_base :
  Scheme.Spec.obj (op $ pullback_affine_cover_ring_base f g i) ⟶ Z :=
Z.affine_cover.map i.1

def pullback_affine_cover_map_fst :
  Scheme.Spec.obj (op $ pullback_affine_cover_ring_left f g i) ⟶
    Scheme.Spec.obj (op $ pullback_affine_cover_ring_base f g i) :=
(pullback f (Z.affine_cover.map i.1)).affine_cover.map i.2.1 ≫ pullback.snd

def pullback_affine_cover_map_snd :
  Scheme.Spec.obj (op $ pullback_affine_cover_ring_right f g i) ⟶
    Scheme.Spec.obj (op $ pullback_affine_cover_ring_base f g i) :=
(pullback g (Z.affine_cover.map i.1)).affine_cover.map i.2.2 ≫ pullback.snd

instance :
  algebra (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring_left f g i) :=
(Scheme.Spec.preimage (pullback_affine_cover_map_fst f g i)).unop.to_algebra

instance :
  algebra (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring_right f g i) :=
(Scheme.Spec.preimage (pullback_affine_cover_map_snd f g i)).unop.to_algebra

def pullback_affine_cover_ring : CommRing :=
CommRing.of $
  tensor_product (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring_left f g i)
    (pullback_affine_cover_ring_right f g i)

instance pullback_affine_cover_ring.left_algebra :
  algebra (pullback_affine_cover_ring_left f g i) (pullback_affine_cover_ring f g i) :=
algebra.tensor_product.left_algebra

instance pullback_affine_cover_ring.right_algebra :
  algebra (pullback_affine_cover_ring_right f g i) (pullback_affine_cover_ring f g i) :=
ring_hom.to_algebra algebra.tensor_product.include_right.to_ring_hom

instance pullback_affine_cover_ring.algebra :
  algebra (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring f g i) :=
algebra.tensor_product.left_algebra

instance pullback_affine_cover_ring.left_tower :
  is_scalar_tower (pullback_affine_cover_ring_base f g i)
    (pullback_affine_cover_ring_left f g i) (pullback_affine_cover_ring f g i) :=
algebra.tensor_product.tensor_product.is_scalar_tower

instance pullback_affine_cover_ring.right_tower :
  is_scalar_tower (pullback_affine_cover_ring_base f g i)
    (pullback_affine_cover_ring_right f g i) (pullback_affine_cover_ring f g i) :=
is_scalar_tower.of_algebra_map_eq' algebra.tensor_product.include_right.comp_algebra_map.symm

lemma pullback_affine_cover_obj :
  (pullback_affine_cover f g).obj i =
    pullback (pullback_affine_cover_map_fst f g i) (pullback_affine_cover_map_snd f g i) := rfl

def pullback_affine_cover_obj_iso :
  (pullback_affine_cover f g).obj i ≅ Scheme.Spec.obj (op $ pullback_affine_cover_ring f g i) :=
begin
  refine (as_iso $ pullback.map _ _ _ _ (𝟙 _) (𝟙 _) (𝟙 _) _ _) ≪≫ pullback_symmetry _ _ ≪≫
    limit.iso_limit_cone ⟨_, ((is_pushout.of_is_colimit (CommRing.pushout_cocone_is_colimit
    (Scheme.Spec.preimage (pullback_affine_cover_map_fst f g i)).unop
      (Scheme.Spec.preimage (pullback_affine_cover_map_snd f g i)).unop))
      .op.map Scheme.Spec).is_limit⟩,
  { simpa only [category.id_comp, quiver.hom.op_unop, functor.image_preimage, category.comp_id] },
  { simpa only [category.id_comp, quiver.hom.op_unop, functor.image_preimage, category.comp_id] },
  apply_instance
end

lemma pullback_affine_cover_obj_iso_inv_fst :
  (pullback_affine_cover_obj_iso f g i).inv ≫ pullback.fst = Scheme.Spec.map (quiver.hom.op $
    (algebra_map (pullback_affine_cover_ring_left f g i) (pullback_affine_cover_ring f g i) : _)) :=
begin
  rw iso.inv_comp_eq,
  simp only [pullback_affine_cover_obj_iso, iso.trans_hom, as_iso_hom, category.assoc],
  erw [limit.iso_limit_cone_hom_π ⟨_, ((is_pushout.of_is_colimit (CommRing.pushout_cocone_is_colimit
    (Scheme.Spec.preimage (pullback_affine_cover_map_fst f g i)).unop
      (Scheme.Spec.preimage (pullback_affine_cover_map_snd f g i)).unop))
      .op.map Scheme.Spec).is_limit⟩ walking_cospan.right, pullback_symmetry_hom_comp_snd],
  rw [pullback.lift_fst, category.comp_id],
end

lemma pullback_affine_cover_obj_iso_inv_snd :
  (pullback_affine_cover_obj_iso f g i).inv ≫ pullback.snd = Scheme.Spec.map (quiver.hom.op $
    (algebra_map (pullback_affine_cover_ring_right f g i) (pullback_affine_cover_ring f g i) : _)) :=
begin
  rw iso.inv_comp_eq,
  simp only [pullback_affine_cover_obj_iso, iso.trans_hom, as_iso_hom, category.assoc],
  erw [limit.iso_limit_cone_hom_π ⟨_, ((is_pushout.of_is_colimit (CommRing.pushout_cocone_is_colimit
    (Scheme.Spec.preimage (pullback_affine_cover_map_fst f g i)).unop
      (Scheme.Spec.preimage (pullback_affine_cover_map_snd f g i)).unop))
      .op.map Scheme.Spec).is_limit⟩ walking_cospan.left, pullback_symmetry_hom_comp_fst],
  rw [pullback.lift_snd, category.comp_id],
end

lemma pullback_affine_cover_map_fst_base :
  pullback_affine_cover_map_fst f g i ≫ pullback_affine_cover_map_base f g i =
    pullback_affine_cover_map_left f g i ≫ f :=
by simp only [category.assoc, pullback_affine_cover_map_base, pullback.condition,
      pullback_affine_cover_map_left, pullback_affine_cover_map_fst]

lemma pullback_affine_cover_map_snd_base :
  pullback_affine_cover_map_snd f g i ≫ pullback_affine_cover_map_base f g i =
    pullback_affine_cover_map_right f g i ≫ g :=
by simp only [category.assoc, pullback_affine_cover_map_base, pullback.condition,
      pullback_affine_cover_map_right, pullback_affine_cover_map_snd]

lemma pullback_affine_cover_map :
  (pullback_affine_cover f g).map i =
    pullback.map (pullback_affine_cover_map_fst f g i) (pullback_affine_cover_map_snd f g i)
    f g (pullback_affine_cover_map_left f g i) (pullback_affine_cover_map_right f g i)
    (pullback_affine_cover_map_base f g i)
    (pullback_affine_cover_map_fst_base f g i)
    (pullback_affine_cover_map_snd_base f g i) :=
begin
  delta pullback_affine_cover,
  apply pullback.hom_ext; simp only [pullback_affine_cover_map_base, pullback_affine_cover_map_left,
    pullback_affine_cover_map_right, pullback.lift_fst, pullback.lift_snd,
    Scheme.open_cover.bind_map, category.assoc, Scheme.pullback.open_cover_of_left_right_map,
    Scheme.pullback.open_cover_of_base_map, pullback.lift_fst_assoc, pullback.lift_snd_assoc],
end
.

lemma pullback_affine_cover_f_exists (T : pullback.triplet f g) :
  ∃ i : (pullback_affine_cover f g).J, T.1 ∈ (pullback_affine_cover_map_left f g i).opens_range ∧
    T.2 ∈ (pullback_affine_cover_map_right f g i).opens_range :=
begin
  let i := Z.affine_cover.f T.z,
  obtain ⟨x, hx⟩ : T.x ∈ (pullback.fst : pullback f (Z.affine_cover.map i) ⟶ _).opens_range,
  { rw [← opens.mem_coe, Scheme.hom.opens_range_coe, pullback.range_fst, set.mem_preimage,
      T.hx], exact Z.affine_cover.covers T.z },
  obtain ⟨y, hy⟩ : T.y ∈ (pullback.fst : pullback g (Z.affine_cover.map i) ⟶ _).opens_range,
  { rw [← opens.mem_coe, Scheme.hom.opens_range_coe, pullback.range_fst, set.mem_preimage,
      T.hy], exact Z.affine_cover.covers T.z },
  refine ⟨⟨i, x, y⟩, _, _⟩,
  { obtain ⟨x', hx'⟩ := (pullback f (Z.affine_cover.map i)).affine_cover.covers x,
    conv_lhs { rw [← hx, ← hx'] }, exact ⟨x', rfl⟩ },
  { obtain ⟨y', hy'⟩ := (pullback g (Z.affine_cover.map i)).affine_cover.covers y,
    conv_lhs { rw [← hy, ← hy'] }, exact ⟨y', rfl⟩ },
end

noncomputable!
def pullback_Top_open_cover : opens (types.pullback_obj f.1.base g.1.base) :=
⟨_, ⟨_, (pullback_affine_cover_map_left f g i).opens_range.prop.prod
  (pullback_affine_cover_map_right f g i).opens_range.prop, rfl⟩⟩

lemma pullback_Top_open_cover_supr :
  supr (pullback_Top_open_cover f g) = ⊤ :=
begin
  rw eq_top_iff,
  rintro ⟨⟨x, y⟩, e⟩ -,
  obtain ⟨i, ⟨x', rfl : _ = x⟩, ⟨y', rfl : _ = y⟩⟩ :=
    pullback_affine_cover_f_exists _ _ (pullback.triplet_mk f g x y e),
  refine opens.mem_supr.mpr ⟨i, ⟨x', rfl⟩, ⟨y', rfl⟩⟩
end

noncomputable!
def pullback_Top_open_cover_preimage_homeo :
  pullback_comparison f g ⁻¹' (pullback_Top_open_cover f g i).1 ≃ₜ
    prime_spectrum (pullback_affine_cover_ring f g i) :=
begin
  have : pullback_comparison f g ⁻¹' (pullback_Top_open_cover f g i).1 =
    ((pullback_affine_cover f g).map i).opens_range,
  { ext x, simp only [pullback_affine_cover_map, set.mem_preimage, Scheme.hom.opens_range_coe,
      pullback.range_map], refl },
  exact ((homeomorph.set_congr this).trans (homeomorph.of_embedding _ (is_open_immersion.base_open
    ((pullback_affine_cover f g).map i)).to_embedding : _).symm).trans
    (Top.homeo_of_iso $ Scheme.forget_to_Top.map_iso $ pullback_affine_cover_obj_iso f g i),
end

noncomputable!
def pullback_Top_open_cover_homeo :
  (pullback_Top_open_cover f g i).1 ≃ₜ types.pullback_obj
    (prime_spectrum.comap $ algebra_map
      (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring_left f g i))
    (prime_spectrum.comap $ algebra_map
      (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring_right f g i)) :=
begin
  refine (homeomorph.of_embedding _ $ embedding_subtype_coe.comp embedding_subtype_coe).trans
    ((homeomorph.set_congr _).trans (homeomorph.of_embedding _ $
    ((is_open_immersion.base_open (pullback_affine_cover_map_left f g i)).to_embedding.prod_mk
      (is_open_immersion.base_open (pullback_affine_cover_map_right f g i)).to_embedding).comp
      embedding_subtype_coe).symm),
    ext x, split, swap,
    { rintros ⟨⟨⟨x, y⟩, e⟩, rfl⟩,
      refine ⟨⟨⟨⟨_, _⟩, _⟩, ⟨x, rfl⟩, ⟨y, rfl⟩⟩, rfl⟩,
      change (pullback_affine_cover_map_left f g i ≫ f).1.base x =
        (pullback_affine_cover_map_right f g i ≫ g).1.base y,
      simp only [ring_hom.algebra_map_to_algebra, ← Scheme.Spec_map_val_base,
        quiver.hom.op_unop, functor.image_preimage] at e,
      rw [← pullback_affine_cover_map_fst_base, ← pullback_affine_cover_map_snd_base,
        Scheme.comp_val_base_apply, Scheme.comp_val_base_apply, e] },
    { rintros ⟨⟨⟨⟨x', y'⟩, e⟩, ⟨x, (rfl : _ = x')⟩, ⟨y, (rfl : _ = y')⟩⟩, rfl⟩,
      refine ⟨⟨⟨x, y⟩, _⟩, rfl⟩,
      change (pullback_affine_cover_map_left f g i ≫ f).1.base x =
        (pullback_affine_cover_map_right f g i ≫ g).1.base y at e,
      apply (is_open_immersion.base_open $ pullback_affine_cover_map_base f g i).inj,
      simp only [ring_hom.algebra_map_to_algebra, ← Scheme.Spec_map_val_base,
        quiver.hom.op_unop, functor.image_preimage, ← Scheme.comp_val_base_apply,
        pullback_affine_cover_map_fst_base, pullback_affine_cover_map_snd_base, e] }
end

lemma homeomorph.trans_symm_apply {α β γ : Type*} [topological_space α] [topological_space β]
  [topological_space γ] (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) (x) :
  (h₁.trans h₂).symm x = h₁.symm (h₂.symm x) := rfl

lemma homeomorph.symm_symm_apply {α β : Type*} [topological_space α] [topological_space β]
  (h : α ≃ₜ β) (x) : h.symm.symm x = h x := rfl

lemma homeomorph.symm_apply_eq {α β : Type*} [topological_space α] [topological_space β]
  (h : α ≃ₜ β) {x y} : h.symm x = y ↔ x = h y := h.to_equiv.symm_apply_eq

lemma homeomorph.coe_set_congr_symm {α : Type*} [topological_space α] (s t : set α)
  (h : s = t) (x) : ((homeomorph.set_congr h).symm x : α) = x := rfl

lemma homeomorph.coe_of_embedding {α β : Type*} [topological_space α] [topological_space β]
  (f : α → β) (hf : embedding f) {x} : (homeomorph.of_embedding f hf x : β) = f x := rfl

lemma Scheme.forget_to_Top_map' {X Y : Scheme} (f : X ⟶ Y) :
  Scheme.forget_to_Top.map f = f.1.base := rfl

lemma pullback_comparison_restrict_pullback_Top_open_cover :
  (pullback_Top_open_cover f g i).1.restrict_preimage (pullback_comparison f g) =
    (pullback_Top_open_cover_homeo f g i).symm ∘ prime_spectrum.tensor_product_to _ _ _ ∘
      pullback_Top_open_cover_preimage_homeo f g i :=
begin
  rw [eq_comm, ← (pullback_Top_open_cover_preimage_homeo f g i).coe_to_equiv,
    ← function.comp.assoc, ← equiv.eq_comp_symm],
  ext x : 1,
  dsimp only [function.comp_apply, subtype.coe_mk,
    pullback_Top_open_cover_preimage_homeo, homeomorph.trans_apply,
      pullback_Top_open_cover_homeo, homeomorph.trans_apply, homeomorph.coe_symm_to_equiv,
      homeomorph.trans_symm_apply, homeomorph.symm_symm_apply],
  rw homeomorph.symm_apply_eq,
  ext1,
  dsimp only [functor.map_iso_inv, Top.homeo_of_iso_symm_apply, Scheme.forget_to_Top_map',
    homeomorph.coe_set_congr_symm, homeomorph.coe_of_embedding, function.comp_apply,
    set.restrict_preimage_coe, prime_spectrum.tensor_product_to_apply_coe_fst,
    prime_spectrum.tensor_product_to_apply_coe_snd],
  ext1,
  { simp only [pullback_comparison_apply_coe_fst, ← Scheme.comp_val_base_apply],
    convert_to (Scheme.Spec.map (quiver.hom.op $ algebra_map
      (pullback_affine_cover_ring_left f g i) (pullback_affine_cover_ring f g i)) ≫
        pullback_affine_cover_map_left f g i).1.base x = _,
    erw ← pullback_affine_cover_obj_iso_inv_fst,
    simp only [category.assoc, pullback_affine_cover_map, pullback.lift_fst] },
  { simp only [pullback_comparison_apply_coe_snd, ← Scheme.comp_val_base_apply],
    convert_to (Scheme.Spec.map (quiver.hom.op $ algebra_map
      (pullback_affine_cover_ring_right f g i) (pullback_affine_cover_ring f g i)) ≫
        pullback_affine_cover_map_right f g i).1.base x = _,
    erw ← pullback_affine_cover_obj_iso_inv_snd,
    simp only [category.assoc, pullback_affine_cover_map, pullback.lift_snd] },
end

end open_cover

instance {R : Type u} [comm_ring R] (x : prime_spectrum R) :
  epi (structure_sheaf.to_stalk R x) :=
begin
  constructor,
  intros Z g h e,
  exact is_localization.ring_hom_ext x.as_ideal.prime_compl e,
end

def _root_.CommRing.iso_of (R : CommRing) : R ≅ CommRing.of R :=
⟨ring_hom.id R, ring_hom.id R, rfl, rfl⟩

def Spec.stalk_map_iso {R S : CommRing.{u}} (f : R ⟶ S) (x) :
  arrow.mk (PresheafedSpace.stalk_map (Scheme.Spec.map f.op).val x) ≅
  arrow.mk (CommRing.of_hom $ localization.at_prime.map f x.as_ideal) :=
begin
  refine arrow.iso_mk' _ _ (structure_sheaf.stalk_iso R (prime_spectrum.comap f x))
    (structure_sheaf.stalk_iso S x) _,
  rw ← cancel_epi (structure_sheaf.to_stalk R (prime_spectrum.comap f x)),
  rw [structure_sheaf.stalk_iso_hom, ← category.assoc,
    structure_sheaf.to_stalk_comp_stalk_to_fiber_ring_hom, structure_sheaf.to_stalk,
    category.assoc],
  erw [PresheafedSpace.stalk_map_germ'_assoc (Scheme.Spec.map f.op).1 x,
    ← Spec_Γ_naturality'_assoc f, ← category.assoc (to_Spec_Γ S),
    structure_sheaf.to_stalk_comp_stalk_to_fiber_ring_hom],
  convert_to (localization.at_prime.map f x.as_ideal).comp
    (algebra_map R (localization (prime_spectrum.comap f x).as_ideal.prime_compl)) =
    (algebra_map S (localization (@prime_spectrum.as_ideal S _ x).prime_compl)).comp f,
  exact is_localization.map_comp _
end
.

lemma surjective_on_stalks_iff {R S : CommRing.{u}} (f : R ⟶ S) :
  f.surjective_on_stalks ↔
    ∀ x, function.surjective (PresheafedSpace.stalk_map (Scheme.Spec.map f.op).1 x) :=
begin
  delta ring_hom.surjective_on_stalks,
  have := λ x, (morphism_property.surjective_respects_iso CommRing).arrow_mk_iso_iff
    (Spec.stalk_map_iso f x),
  dsimp only [morphism_property.surjective] at this, simp_rw this,
  exact ⟨λ H x, H x.as_ideal, λ H x hx, H ⟨x, hx⟩⟩
end

lemma Scheme.open_cover.exists_covers {X : Scheme} (𝒰 : X.open_cover) (x : X.carrier) :
  ∃ i (y : (𝒰.obj i).carrier), (𝒰.map i).1.base y = x :=
⟨_, 𝒰.covers x⟩

lemma Scheme.comp_val' {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).1 = @category_struct.comp (PresheafedSpace.{u} CommRing.{u}) _ _ _ _ f.1 g.1 := rfl

include hg

lemma pullback_snd_surjective_on_stalks (x) : function.surjective
  (PresheafedSpace.stalk_map (pullback.fst : pullback f g ⟶ _).1 x) :=
begin
  obtain ⟨i, y, rfl⟩ := (pullback_affine_cover f g).exists_covers x,
  refine ((morphism_property.surjective_respects_iso CommRing).cancel_right_is_iso _
    (PresheafedSpace.stalk_map ((pullback_affine_cover f g).map i).1 _)).mp _,
  rw ← PresheafedSpace.stalk_map.comp,
  change morphism_property.surjective _ (PresheafedSpace.stalk_map
    ((pullback_affine_cover f g).map i ≫ pullback.fst).1 y),
  rw [pullback_affine_cover_map, pullback.lift_fst, Scheme.comp_val',
    PresheafedSpace.stalk_map.comp,
    (morphism_property.surjective_respects_iso CommRing).cancel_left_is_iso,
    ← (pullback_affine_cover_obj_iso f g i).hom_inv_id_assoc pullback.fst,
    pullback_affine_cover_obj_iso_inv_fst, Scheme.comp_val',
    PresheafedSpace.stalk_map.comp,
    (morphism_property.surjective_respects_iso CommRing).cancel_right_is_iso],
  erw (morphism_property.surjective_respects_iso CommRing).arrow_mk_iso_iff
    (Spec.stalk_map_iso _ _),
  convert tensor_product_surjective_on_stalks
    (pullback_affine_cover_ring_base f g i) (pullback_affine_cover_ring_left f g i)
    (pullback_affine_cover_ring_right f g i) _
    (((pullback_affine_cover_obj_iso f g i).hom.1.base) y).as_ideal,
  intros x hx,
  refine ((morphism_property.surjective_respects_iso CommRing).arrow_mk_iso_iff
    (Spec.stalk_map_iso _ ⟨x, hx⟩)).mp _,
  rw [ring_hom.algebra_map_to_algebra, quiver.hom.op_unop, functor.image_preimage],
  refine ((morphism_property.surjective_respects_iso CommRing).cancel_left_is_iso
    (PresheafedSpace.stalk_map (pullback_affine_cover_map_base f g i).1 _) _).mp _,
  rw ← PresheafedSpace.stalk_map.comp,
  change morphism_property.surjective _ (PresheafedSpace.stalk_map
    (pullback_affine_cover_map_snd f g i ≫ pullback_affine_cover_map_base f g i).1 _),
  rw [pullback_affine_cover_map_snd_base, Scheme.comp_val', PresheafedSpace.stalk_map.comp,
    (morphism_property.surjective_respects_iso CommRing).cancel_right_is_iso],
  exact hg _,
end

lemma embedding_pullback_comparison_of_surjective_on_stalks :
  embedding (pullback_comparison f g) :=
begin
  refine (embedding_iff_embedding_of_supr_eq_top (pullback_Top_open_cover_supr f g)
    (pullback_comparison f g).2).mpr (λ i, _),
  erw pullback_comparison_restrict_pullback_Top_open_cover,
  refine (homeomorph.embedding _).comp (embedding.comp _ $ homeomorph.embedding _),
  apply prime_spectrum.tensor_product_to_embedding,
  rw surjective_on_stalks_iff,
  intro x,
  rw [ring_hom.algebra_map_to_algebra, quiver.hom.op_unop, functor.image_preimage,
    pullback_affine_cover_map_snd],
  refine ((morphism_property.surjective_respects_iso CommRing).cancel_left_is_iso
    (PresheafedSpace.stalk_map (Z.affine_cover.map i.fst).1 _) _).mp _,
  rw ← PresheafedSpace.stalk_map.comp,
  convert_to function.surjective
    (PresheafedSpace.stalk_map ((_ ≫ pullback.snd) ≫ Z.affine_cover.map i.1).1 x),
  rw [category.assoc, ← pullback.condition, ← category.assoc, Scheme.comp_val],
  erw PresheafedSpace.stalk_map.comp,
  exact (as_iso $ PresheafedSpace.stalk_map ((pullback g (Z.affine_cover.map i.1)).affine_cover.map
    i.2.2 ≫ pullback.fst).1 x).CommRing_iso_to_ring_equiv.surjective.comp (hg _),
end

lemma embedding_category_theory_pullback_comparison_of_surjective_on_stalks :
  embedding (category_theory.limits.pullback_comparison Scheme.forget_to_Top f g) :=
begin
  rw ← pullback_comparison_comp_pullback_iso_prod_subtype_inv,
  exact (Top.homeo_of_iso (Top.pullback_iso_prod_subtype f.val.base g.val.base).symm)
    .embedding.comp (embedding_pullback_comparison_of_surjective_on_stalks f g hg),
end

end algebraic_geometry