import .basic

namespace polya.field

namespace nterm

namespace pform

variables {α : Type} [discrete_field α]
variables {γ : Type} [const_space γ]
variables [morph γ α] {ρ : dict α}

instance : has_coe (option (nterm γ)) (nterm γ) := ⟨λ x, x.get_or_else (const 1)⟩

private lemma eval_none : eval ρ ((none : option (nterm γ)) : nterm γ) = 1 :=
by apply morph.morph_one'

private lemma eval_some {x : nterm γ} : eval ρ (some x : nterm γ) = eval ρ x := rfl

local attribute [simp] eval_none
local attribute [simp] eval_some

private def to_pform : nterm γ → option (nterm γ) | x :=
if x = const 1 then none else some x --TODO

private lemma eval_to_pform {x : nterm γ} : eval ρ (to_pform x : nterm γ) = eval ρ x :=
begin
  unfold to_pform,
  by_cases h1 : x = const 1,
  repeat { simp [h1, eval] },
end

@[simp] theorem eval_pow_mul_option {x : option (nterm γ)} {n : znum} : eval ρ (x.map (pow_mul n) : nterm γ) = eval ρ (x : nterm γ) ^ (n : ℤ) :=
by cases x; simp

private def mul' : option (nterm γ) → nterm γ → nterm γ
| (some x) y :=
  let d := znum.gcd x.exp y.exp in
    some $ pow_mul d $ mul (x.pow_div d) (y.pow_div d)
| none y := y

private lemma eval_mul' {x : option (nterm γ)} {y : nterm γ} :
  eval ρ (mul' x y) = eval ρ (x : nterm γ) * eval ρ y :=
begin
  cases x with x,
  { simp [mul'] },
  rw eval_some, unfold mul',
  --generalize : d = znum.gcd (exp x) (exp y) : znum,
  --have h1 : (d : znum) ∣ exp x, from sorry,
  --have h2 : (d : znum) ∣ exp y, from sorry,
  rw [eval_some, eval_pow_mul], unfold eval,
  rw [mul_fpow, eval_pow_div, eval_pow_div],
  { sorry },
  { sorry }
end

private def left : nterm γ → option (nterm γ)
| (mul x _) := some x
| _ := none

private def right : nterm γ → (nterm γ)
| (mul _ x) := x
| x := x

def rest (P : nterm γ) : option (nterm γ) := (left P.mem).map (pow_mul P.exp)

def lead (P : nterm γ) : nterm γ := pow_mul P.exp (right P.mem)

theorem eval_left_right (x : nterm γ) :
  eval ρ x = eval ρ (left x : nterm γ) * eval ρ (right x) :=
begin
  cases x,
  case mul : x y { simp [left, right, eval] },
  repeat { simp [left, right, eval] }
end

theorem eval_rest_lead {P : nterm γ} :
  eval ρ P = eval ρ (rest P : nterm γ) * eval ρ (lead P) :=
begin
  rw [eval_mem_exp, eval_left_right, mul_fpow],
  congr' 1,
  { unfold rest, cases (mem P); simp [left] },
  { unfold lead, rw eval_pow_mul }
end

inductive r : option (nterm γ) → option (nterm γ) → Prop
| none {S : nterm γ} : r none (some S)
| rest {S : nterm γ} : r (rest S) (some S)

namespace wf

private lemma acc_r_none : @acc (option (nterm γ)) r none :=
begin
  apply acc.intro, intros x h, cases h
end

private def g : nterm γ → ℕ
| (add x _) := g x + 1
| (mul x (const _)) := g x
| _ := 0

private def f : option (nterm γ) → ℕ
| (some x) := g x + 1
| none := 0

private lemma g_scale {x : nterm γ} {a : γ} : g (x.scale a) ≤ g x :=
begin
  sorry
end

private lemma f_none {S : nterm γ} : f (none : option (nterm γ)) < f (some S) :=
by { unfold f, linarith }

private lemma f_map_scale {x : option (nterm γ)} {a : γ} : f (x.map (scale a)) ≤ f x :=
by { cases x; simp [f, g_scale] }

private lemma f_rest {S : nterm γ} : f (rest S) < f (some S) :=
begin
  sorry
end

theorem r_wf : @well_founded (option (nterm γ)) r :=
begin
  apply subrelation.wf,
  intros x y h,
  show f x < f y,
  cases h, { apply f_none }, { apply f_rest },
  apply measure_wf
end

meta def rel_tac : tactic unit := `[exact ⟨psigma.lex r (λ _, r), psigma.lex_wf wf.r_wf (λ _, wf.r_wf)⟩]

meta def dec_tac : tactic unit :=
`[apply psigma.lex.left, assumption, done]
<|> `[apply psigma.lex.right, assumption, done]

end wf

private def aux (x y : nterm γ) (p1 p2 p3 : option (nterm γ)) : nterm γ :=
if x.mem = y.mem then
  if x.exp + y.exp = 0 then (p1 : nterm γ)
  else mul' p1 (pow x.mem (x.exp + y.exp))
else if x.term < y.term then --TODO
  mul' p2 x
else
  mul' p3 y

private lemma eval_aux_1 {x y : nterm γ} {p1 p2 p3 : option (nterm γ)}
  ( H0 : x.exp + y.exp ≠ 0)
  ( H1 : eval ρ (p2 : nterm γ) = eval ρ (p1 : nterm γ) * eval ρ y )
  ( H2 : eval ρ (p3 : nterm γ) = eval ρ (p1 : nterm γ) * eval ρ x ) :
  eval ρ (aux x y p1 p2 p3) =  eval ρ (p1 : nterm γ) * eval ρ y * eval ρ x :=
begin
  unfold aux,
  by_cases h1 : x.mem = y.mem,
  { rw [if_pos h1, mul_assoc],
    { rw if_neg H0, rw [eval_mul'], congr,
      unfold eval,
      by_cases h2 : exp x = 0,
      { have : eval ρ x = 1, { rw [eval_mem_exp x, h2], simp }, rw [h1, h2, this, eval_mem_exp y], simp, },
      { by_cases h3 : eval ρ (mem x) = 0,
        { have : eval ρ x = 0, { rw [eval_mem_exp x, h3, zero_fpow], rw ← znum.cast_zero, exact_mod_cast h2 },
          rw [h3, zero_fpow, this, mul_zero],
          rw ← znum.cast_zero, exact_mod_cast H0 },
        { rw [znum.cast_add, fpow_add h3],
          rw [← eval_mem_exp, h1, ← eval_mem_exp, mul_comm] }}}},
  { rw if_neg h1,
    by_cases h2 : x.term < y.term,
    { rw if_pos h2, rw [eval_mul'], congr, apply H1 },
    { rw if_neg h2, rw [mul_assoc, mul_comm (eval ρ y), ← mul_assoc, eval_mul'], congr, apply H2 }}
end

private def mul_option : option (nterm γ) → option (nterm γ) → option (nterm γ)
| (some x) (some y) := mul' (some x) y --TODO
| none x := x
| x none := x

private lemma mul_pform_def1 {x : option (nterm γ)} :
  mul_option none x = x :=
by cases x; unfold mul_option

private lemma mul_pform_def2 {x : option (nterm γ)} :
  mul_option x none = x :=
by cases x; unfold mul_option

local attribute [simp] mul_pform_def1
local attribute [simp] mul_pform_def2

private lemma eval_mul_option {P Q : option (nterm γ)} : eval ρ (mul_option P Q : nterm γ) = eval ρ (P : nterm γ) * eval ρ (Q : nterm γ) :=
begin
  cases P, { simp },
  cases Q, { simp },
  exact eval_mul'
end

protected def mul (x y : nterm γ) : nterm γ :=
if x = const 0 ∨ y = const 0 then
  const 0
else
  mul (mul_option (to_pform x.term) (to_pform y.term)) (const (x.coeff * y.coeff))

theorem eval_mul {x y : nterm γ} : eval ρ (pform.mul x y) = eval ρ x * eval ρ y :=
begin
  unfold pform.mul,
  by_cases h1 : x = const 0 ∨ y = const 0,
  { cases h1; simp [h1, eval] },
  { rw if_neg h1, unfold eval,
    rw [eval_mul_option, eval_to_pform, eval_to_pform, morph.morph_mul],
    rw [mul_assoc, mul_comm (↑(coeff x)), ← mul_assoc (eval ρ (term y))],
    rw [← eval_term_coeff, mul_comm (eval ρ y), ← mul_assoc],
    rw [← eval_term_coeff] }
end

end pform

end nterm

end polya.field


import Runtime.Execution.Basic

namespace Execution.Executable
open Network

def nextTime (exec : Executable net) : Option (Time.From exec.time) :=
  match exec.state with
  | .shuttingDown    => none
  | .shutdownPending => some exec.time
  | .executing       => exec.queue.nextTime

theorem nextTime_le_queue_nextTime {exec : Executable net} {t q} :
  (exec.nextTime = some t) → (exec.queue.nextTime = some q) → (t ≤ q) := by
  intro ht hq
  simp [nextTime] at ht
  split at ht <;> simp_all
  simp [←ht]
  exact q.property

private def propagationEvents (exec : Executable net) : Queue (Event net) exec.time where
  events :=
    exec.toPropagate.uniqueMergeMap (le := (·.time ≤ ·.time)) fun port =>
      match exec.reactors port.reactor |>.interface .outputs port.port with
      | none => #[] -- TODO: This case is unreachable by the semantics of `toPropagate`.
      | some value =>
        let events := port.delayedDestinations.map fun { dst, delay, eqType } =>
          Event.propagation (exec.time + delay) dst (eqType ▸ value)
        events.insertionSort (·.time ≤ ·.time) -- TODO: Use `qsort` when it drops `[Inhabited α]`.
  sorted := sorry
  bounded := sorry

private def nextTimerEvents (exec : Executable net) (timers : Array (TimerId net)) (anchor : Time) :
  Queue (Event net) anchor where
  events :=
    timers.filterMap fun ⟨reactor, timer⟩ =>
      match exec.reactors reactor |>.timer timer |>.val.period with
      | none => none
      | some period => return .timer (anchor + period) ⟨reactor, timer⟩
  sorted := sorry
  bounded := sorry

structure Next (net : Network) where
  tag    : Tag
  events : Array (Event net)
  queue  : Queue (Event net) tag.time

namespace Next

def empty (tag : Tag) : Next net where
  tag := tag
  events := #[]
  queue := °[]

protected def «for» (exec : Executable net) : Option (Next net) :=
  -- TODO: It feels like this doesn't belong here.
  let exec := { exec with queue := exec.queue.merge exec.propagationEvents }
  match h : exec.nextTime with
  | none => none
  | some time =>
    -- TODO: We can't destruct here, as this causes problems in the proof of `bounded` below.
    let eventSplit := exec.queue.split time (fun _ h' => nextTime_le_queue_nextTime h h')
    let events := eventSplit.fst
    let later := eventSplit.snd
    let timers := events.filterMap (·.timer?)
    let timerEvents := exec.nextTimerEvents timers time
    some {
      tag    := exec.tag.advance time
      events := events
      queue  := Tag.advance_time ▸ later.merge timerEvents
    }

theorem for_tag_strictly_monotonic (exec : Executable net) :
  (Next.for exec = some next) → (exec.tag < next.tag) := by
  intro h
  simp [Next.for] at h
  split at h
  · contradiction
  · simp at h
    simp [←h, Tag.lt_advance]

theorem for_isSome_if_shutdownPending {exec : Executable net} :
  (exec.state = .shutdownPending) → (Next.for exec).isSome :=
  sorry

/- TODO: Requires List.Perm
theorem for_preserves_events :
  (Next.for exec = some next) →
  ∃ timerEvents propagationEvents,
    (next.events ++ next.queue.events) ~ (exec.queue.events ++ timerEvents ++ propagationEvents) := by
  sorry
-/

-- The actions-interface for a given reactor according to the `Next` instance.
def actions (next : Next net) (reactor : ReactorId net) :
  Interface? (reactor.class.interface .actions) :=
  fun action =>
    match h : next.events.findP? (·.id = .action ⟨reactor, action⟩) with
    | none       => none
    | some event => have h := Array.findP?_property h; event.actionValue (of_decide_eq_true h)

-- The inputs-interface for a given reactor according to the `Next` instance.
def inputs (next : Next net) (reactor : ReactorId net) :
  Interface? (reactor.class.interface .inputs) :=
  fun input =>
    match h : next.events.findP? (·.id = .propagation ⟨reactor, input⟩) with
    | none => none
    | some event => have h := Array.findP?_property h; event.propagationValue (of_decide_eq_true h)

def timers (next : Next net) (exec : Executable net) (reactor : ReactorId net) :
  reactor.class.timers → Reactor.Timer :=
  fun timer => {
    val      := exec.reactors reactor |>.timer timer |>.val
    isFiring := next.events.any (·.timer? = some ⟨reactor, timer⟩)
  }

end Next
end Execution.Executable


/-
File: signature_recover_public_key_ec_add_soundness.lean

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

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

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

/- starkware.cairo.common.cairo_secp.ec.ec_add autogenerated soundness theorem -/

theorem auto_sound_ec_add
    -- arguments
    (range_check_ptr : F) (point0 point1 : EcPoint F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_ec_add σ.pc)
    -- all dependencies are in memory
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 404))
    (h_mem_5 : mem_at mem code_unreduced_mul (σ.pc  - 392))
    (h_mem_6 : mem_at mem code_unreduced_sqr (σ.pc  - 372))
    (h_mem_7 : mem_at mem code_verify_zero (σ.pc  - 356))
    (h_mem_8 : mem_at mem code_is_zero (σ.pc  - 333))
    (h_mem_12 : mem_at mem code_compute_doubling_slope (σ.pc  - 228))
    (h_mem_13 : mem_at mem code_compute_slope (σ.pc  - 184))
    (h_mem_14 : mem_at mem code_ec_double (σ.pc  - 160))
    (h_mem_15 : mem_at mem code_fast_ec_add (σ.pc  - 87))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 15))
    (hin_point0 : point0 = cast_EcPoint mem (σ.fp - 14))
    (hin_point1 : point1 = cast_EcPoint mem (σ.fp - 8))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 15)) (mem $ τ.ap - 7)
        (spec_ec_add mem κ range_check_ptr point0 point1 (mem (τ.ap - 7)) (cast_EcPoint mem (τ.ap - 6)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_ec_add 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, hpc23, hpc24, hpc25, hpc26, hpc27, hpc28, hpc29, hpc30, hpc31, hpc32, hpc33, hpc34, hpc35, hpc36, hpc37, hpc38, hpc39, hpc40, hpc41, hpc42, hpc43, hpc44, hpc45, hpc46, hpc47, hpc48, hpc49, hpc50, hpc51, hpc52, hpc53, hpc54, hpc55⟩,
  -- let
  generalize' hl_rev_x_diff: ({
    d0 := point0.x.d0 - point1.x.d0,
    d1 := point0.x.d1 - point1.x.d1,
    d2 := point0.x.d2 - point1.x.d2
  } : BigInt3 F) = x_diff,
  have hl_x_diff := hl_rev_x_diff.symm, clear hl_rev_x_diff,
  try { dsimp at hl_x_diff }, try { arith_simps at hl_x_diff },
  -- function call
  step_assert_eq hpc0 with arg0,
  step_assert_eq hpc1 with arg1,
  step_assert_eq hpc2 with arg2,
  step_assert_eq hpc3 with arg3,
  step_sub hpc4 (auto_sound_is_zero mem _ range_check_ptr x_diff _ _ _ _ _ _),
  { rw hpc5, norm_num2, exact h_mem_8 },
  { rw hpc5, norm_num2, exact h_mem_4 },
  { rw hpc5, norm_num2, exact h_mem_5 },
  { rw hpc5, norm_num2, exact h_mem_7 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff] },
    try { dsimp [cast_EcPoint, cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), (eq_sub_of_eq_add arg3)] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, (eq_sub_of_eq_add arg1), (eq_sub_of_eq_add arg2), (eq_sub_of_eq_add arg3)] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call6 ap6 h_call6,
  rcases h_call6 with ⟨rc_m6, rc_mle6, hl_range_check_ptr₁, h_call6⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap6 - 2) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  generalize' hr_rev_same_x: mem (ap6 - 1) = same_x,
  simp only [hr_rev_same_x] at h_call6,
  have htv_same_x := hr_rev_same_x.symm, clear hr_rev_same_x,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3] at h_call6 },
  rw [hin_range_check_ptr] at h_call6,
  clear arg0 arg1 arg2 arg3,
  -- if statement
  step_jnz hpc6 hpc7 with hcond hcond,
  {
    -- if: positive branch
    have a6 : same_x = 0, {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [hcond] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    },
    try { dsimp at a6 }, try { arith_simps at a6 },
    clear hcond,
    -- tail function call
    step_assert_eq hpc8 with arg0,
    step_assert_eq hpc9 with arg1,
    step_assert_eq hpc10 with arg2,
    step_assert_eq hpc11 with arg3,
    step_assert_eq hpc12 with arg4,
    step_assert_eq hpc13 with arg5,
    step_assert_eq hpc14 with arg6,
    step_assert_eq hpc15 with arg7,
    step_assert_eq hpc16 with arg8,
    step_assert_eq hpc17 with arg9,
    step_assert_eq hpc18 with arg10,
    step_assert_eq hpc19 with arg11,
    step_assert_eq hpc20 with arg12,
    step_sub hpc21 (auto_sound_fast_ec_add mem _ range_check_ptr₁ point0 point1 _ _ _ _ _ _ _ _ _),
    { rw hpc22, norm_num2, exact h_mem_15 },
    { rw hpc22, norm_num2, exact h_mem_4 },
    { rw hpc22, norm_num2, exact h_mem_5 },
    { rw hpc22, norm_num2, exact h_mem_6 },
    { rw hpc22, norm_num2, exact h_mem_7 },
    { rw hpc22, norm_num2, exact h_mem_13 },
    { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x] },
        try { dsimp [cast_EcPoint, cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x] },
        try { dsimp [cast_EcPoint, cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    intros κ_call23 ap23 h_call23,
    rcases h_call23 with ⟨rc_m23, rc_mle23, hl_range_check_ptr₂, h_call23⟩,
    step_ret hpc23,
    generalize' hr_rev_range_check_ptr₂: mem (ap23 - 7) = range_check_ptr₂,
    have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6 ,arg7 ,arg8 ,arg9 ,arg10 ,arg11 ,arg12] at hl_range_check_ptr₂ },
    rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6 ,arg7 ,arg8 ,arg9 ,arg10 ,arg11 ,arg12] at h_call23 },
    rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call23,
    clear arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12,
    -- finish
    step_done, use_only [rfl, rfl],
    -- range check condition
    use_only (rc_m6+rc_m23+0+0), split,
    linarith [rc_mle6, rc_mle23],
    split,
    { arith_simps,
      rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
      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_ec_add mem _ range_check_ptr point0 point1 _ _,
    { apply sound_ec_add, apply auto_spec },
    -- prove the auto generated assertion
    dsimp [auto_spec_ec_add],
    try { norm_num1 }, try { arith_simps },
    use_only [x_diff, hl_x_diff],
    use_only [κ_call6],
    use_only [range_check_ptr₁],
    use_only [same_x],
    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₁' },
    have spec6 := h_call6 rc_h_range_check_ptr',
    rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec6,
    try { dsimp at spec6, arith_simps at spec6 },
    use_only [spec6],
    left,
    use_only [a6],
    use_only [κ_call23],
    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₂' },
    have spec23 := h_call23 rc_h_range_check_ptr₁',
    rw [←hin_range_check_ptr, ←hl_range_check_ptr₁] at spec23,
    try { dsimp at spec23, arith_simps at spec23 },
    use_only [spec23],
    try { linarith },
  },
  {
    -- if: negative branch
    have a6 : same_x ≠ 0, {
      try { simp only [ne.def] },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [hcond] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    },
    try { dsimp at a6 }, try { arith_simps at a6 },
    clear hcond,
    -- let
    generalize' hl_rev_y_sum: ({
      d0 := point0.y.d0 + point1.y.d0,
      d1 := point0.y.d1 + point1.y.d1,
      d2 := point0.y.d2 + point1.y.d2
    } : BigInt3 F) = y_sum,
    have hl_y_sum := hl_rev_y_sum.symm, clear hl_rev_y_sum,
    try { dsimp at hl_y_sum }, try { arith_simps at hl_y_sum },
    -- function call
    step_assert_eq hpc24 with arg0,
    step_assert_eq hpc25 with arg1,
    step_assert_eq hpc26 with arg2,
    step_assert_eq hpc27 with arg3,
    step_sub hpc28 (auto_sound_is_zero mem _ range_check_ptr₁ y_sum _ _ _ _ _ _),
    { rw hpc29, norm_num2, exact h_mem_8 },
    { rw hpc29, norm_num2, exact h_mem_4 },
    { rw hpc29, norm_num2, exact h_mem_5 },
    { rw hpc29, norm_num2, exact h_mem_7 },
    { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    { try { ext } ; {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum] },
        try { dsimp [cast_EcPoint, cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
    intros κ_call30 ap30 h_call30,
    rcases h_call30 with ⟨rc_m30, rc_mle30, hl_range_check_ptr₂, h_call30⟩,
    generalize' hr_rev_range_check_ptr₂: mem (ap30 - 2) = range_check_ptr₂,
    have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
    generalize' hr_rev_opposite_y: mem (ap30 - 1) = opposite_y,
    simp only [hr_rev_opposite_y] at h_call30,
    have htv_opposite_y := hr_rev_opposite_y.symm, clear hr_rev_opposite_y,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3] at hl_range_check_ptr₂ },
    rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
    try { simp only [arg0 ,arg1 ,arg2 ,arg3] at h_call30 },
    rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call30,
    clear arg0 arg1 arg2 arg3,
    -- if statement
    step_jnz hpc30 hpc31 with hcond hcond,
    {
      -- if: positive branch
      have a30 : opposite_y = 0, {
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum, htv_range_check_ptr₂, htv_opposite_y] },
        try { dsimp [cast_EcPoint, cast_BigInt3] },
        try { arith_simps }, try { simp only [hcond] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
      },
      try { dsimp at a30 }, try { arith_simps at a30 },
      clear hcond,
      -- tail function call
      step_assert_eq hpc32 with arg0,
      step_assert_eq hpc33 with arg1,
      step_assert_eq hpc34 with arg2,
      step_assert_eq hpc35 with arg3,
      step_assert_eq hpc36 with arg4,
      step_assert_eq hpc37 with arg5,
      step_assert_eq hpc38 with arg6,
      step_sub hpc39 (auto_sound_ec_double mem _ range_check_ptr₂ point0 _ _ _ _ _ _ _ _),
      { rw hpc40, norm_num2, exact h_mem_14 },
      { rw hpc40, norm_num2, exact h_mem_4 },
      { rw hpc40, norm_num2, exact h_mem_5 },
      { rw hpc40, norm_num2, exact h_mem_6 },
      { rw hpc40, norm_num2, exact h_mem_7 },
      { rw hpc40, norm_num2, exact h_mem_12 },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum, htv_range_check_ptr₂, htv_opposite_y] },
        try { dsimp [cast_EcPoint, cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      { try { ext } ; {
          try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum, htv_range_check_ptr₂, htv_opposite_y] },
          try { dsimp [cast_EcPoint, cast_BigInt3] },
          try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6] },
          try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
      intros κ_call41 ap41 h_call41,
      rcases h_call41 with ⟨rc_m41, rc_mle41, hl_range_check_ptr₃, h_call41⟩,
      step_ret hpc41,
      generalize' hr_rev_range_check_ptr₃: mem (ap41 - 7) = range_check_ptr₃,
      have htv_range_check_ptr₃ := hr_rev_range_check_ptr₃.symm, clear hr_rev_range_check_ptr₃,
      try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6] at hl_range_check_ptr₃ },
      rw [←htv_range_check_ptr₃, ←htv_range_check_ptr₂] at hl_range_check_ptr₃,
      try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6] at h_call41 },
      rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call41,
      clear arg0 arg1 arg2 arg3 arg4 arg5 arg6,
      -- finish
      step_done, use_only [rfl, rfl],
      -- range check condition
      use_only (rc_m6+rc_m30+rc_m41+0+0), split,
      linarith [rc_mle6, rc_mle30, rc_mle41],
      split,
      { arith_simps,
        rw [←htv_range_check_ptr₃, hl_range_check_ptr₃, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
        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_ec_add mem _ range_check_ptr point0 point1 _ _,
      { apply sound_ec_add, apply auto_spec },
      -- prove the auto generated assertion
      dsimp [auto_spec_ec_add],
      try { norm_num1 }, try { arith_simps },
      use_only [x_diff, hl_x_diff],
      use_only [κ_call6],
      use_only [range_check_ptr₁],
      use_only [same_x],
      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₁' },
      have spec6 := h_call6 rc_h_range_check_ptr',
      rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec6,
      try { dsimp at spec6, arith_simps at spec6 },
      use_only [spec6],
      right,
      use_only [a6],
      use_only [y_sum, hl_y_sum],
      use_only [κ_call30],
      use_only [range_check_ptr₂],
      use_only [opposite_y],
      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₂' },
      have spec30 := h_call30 rc_h_range_check_ptr₁',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec30,
      try { dsimp at spec30, arith_simps at spec30 },
      use_only [spec30],
      right,
      use_only [a30],
      use_only [κ_call41],
      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₃' },
      have spec41 := h_call41 rc_h_range_check_ptr₂',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂] at spec41,
      try { dsimp at spec41, arith_simps at spec41 },
      use_only [spec41],
      try { linarith },
    },
    {
      -- if: negative branch
      have a30 : opposite_y ≠ 0, {
        try { simp only [ne.def] },
        try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum, htv_range_check_ptr₂, htv_opposite_y] },
        try { dsimp [cast_EcPoint, cast_BigInt3] },
        try { arith_simps }, try { simp only [hcond] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
      },
      try { dsimp at a30 }, try { arith_simps at a30 },
      clear hcond,
      -- let
      generalize' hl_rev_ZERO_POINT: ({
        x := { d0 := 0, d1 := 0, d2 := 0 },
        y := { d0 := 0, d1 := 0, d2 := 0 }
      } : EcPoint F) = ZERO_POINT,
      have hl_ZERO_POINT := hl_rev_ZERO_POINT.symm, clear hl_rev_ZERO_POINT,
      try { dsimp at hl_ZERO_POINT }, try { arith_simps at hl_ZERO_POINT },
      -- return
      step_assert_eq hpc42 with hret0,
      step_assert_eq hpc43 hpc44 with hret1,
      step_assert_eq hpc45 hpc46 with hret2,
      step_assert_eq hpc47 hpc48 with hret3,
      step_assert_eq hpc49 hpc50 with hret4,
      step_assert_eq hpc51 hpc52 with hret5,
      step_assert_eq hpc53 hpc54 with hret6,
      step_ret hpc55,
      -- finish
      step_done, use_only [rfl, rfl],
      -- range check condition
      use_only (rc_m6+rc_m30+0+0), split,
      linarith [rc_mle6, rc_mle30],
      split,
      { arith_simps, try { simp only [hret0 ,hret1 ,hret2 ,hret3 ,hret4 ,hret5 ,hret6] },
        rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
        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_ec_add mem _ range_check_ptr point0 point1 _ _,
      { apply sound_ec_add, apply auto_spec },
      -- prove the auto generated assertion
      dsimp [auto_spec_ec_add],
      try { norm_num1 }, try { arith_simps },
      use_only [x_diff, hl_x_diff],
      use_only [κ_call6],
      use_only [range_check_ptr₁],
      use_only [same_x],
      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₁' },
      have spec6 := h_call6 rc_h_range_check_ptr',
      rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec6,
      try { dsimp at spec6, arith_simps at spec6 },
      use_only [spec6],
      right,
      use_only [a6],
      use_only [y_sum, hl_y_sum],
      use_only [κ_call30],
      use_only [range_check_ptr₂],
      use_only [opposite_y],
      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₂' },
      have spec30 := h_call30 rc_h_range_check_ptr₁',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec30,
      try { dsimp at spec30, arith_simps at spec30 },
      use_only [spec30],
      left,
      use_only [a30],
      use_only [ZERO_POINT, hl_ZERO_POINT],
      try { split, linarith },
      try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point0, hin_point1, hl_x_diff, htv_range_check_ptr₁, htv_same_x, hl_y_sum, htv_range_check_ptr₂, htv_opposite_y, hl_ZERO_POINT] }, },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [hret0, hret1, hret2, hret3, hret4, hret5, hret6] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    }
  }
end


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 ⟨⟩⟩


open tactic
open lean.parser
open interactive

namespace tactic.interactive

open lean
open lean.parser

private meta def resolve_name' (n : name) : tactic expr :=
do {
  p ← resolve_name n,
  match p.to_raw_expr with
  | expr.const n _           := mk_const n -- create metavars for universe levels
  | _                        := i_to_expr p
  end
}

private meta def to_expr' (p : pexpr) : tactic expr :=
let e := p.to_raw_expr in
match e with
| (expr.const c [])          := do new_e ← resolve_name' c, save_type_info new_e e, return new_e
| (expr.local_const c _ _ _) := do new_e ← resolve_name' c, save_type_info new_e e, return new_e
| _                     := i_to_expr p
end

private meta def rw_goal_gos (m : transparency) (r : rw_rule) : tactic unit :=
save_info r.pos >> to_expr' r.rule >>= rewrite_core m tt tt occurrences.all r.symm

  meta def rewrite_nth (r : parse ident) (n : nat) : tactic unit :=
  do e ← tactic.mk_const r,
    tactic.rewrite_core reducible tt tt (occurrences.pos [n]) tt r
end tactic.interactive

lemma foo (p : 1 = 2): [ 1,1,1,2,1 ] = [ 1,1,2,2,1 ] :=
begin
induction p,
  rewrite_nth p 3,
end