/-
File: signature_recover_public_key_validate_reduced_field_element_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_assert_nn_le_soundness
open tactic

open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.math
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.validate_reduced_field_element autogenerated soundness theorem -/

theorem auto_sound_validate_reduced_field_element
    -- arguments
    (range_check_ptr : F) (val : BigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_validate_reduced_field_element σ.pc)
    -- all dependencies are in memory
    (h_mem_0 : mem_at mem code_assert_nn (σ.pc  - 152))
    (h_mem_1 : mem_at mem code_assert_le (σ.pc  - 148))
    (h_mem_2 : mem_at mem code_assert_nn_le (σ.pc  - 143))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 6))
    (hin_val : val = cast_BigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 6)) (mem $ τ.ap - 1)
        (spec_validate_reduced_field_element mem κ range_check_ptr val (mem (τ.ap - 1)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_validate_reduced_field_element 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⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_assert_eq hpc1 with arg1,
  step_assert_eq hpc2 hpc3 with arg2,
  step_sub hpc4 (auto_sound_assert_nn_le mem _ range_check_ptr val.d2 P2 _ _ _ _ _ _),
  { rw hpc5, norm_num2, exact h_mem_2 },
  { rw hpc5, norm_num2, exact h_mem_0 },
  { rw hpc5, norm_num2, exact h_mem_1 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call6 ap6 h_call6,
  rcases h_call6 with ⟨h_call6_ap_offset, h_call6⟩,
  rcases h_call6 with ⟨rc_m6, rc_mle6, hl_range_check_ptr₁, h_call6⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap6 - 1) = 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] 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] at h_call6 },
  rw [hin_range_check_ptr] at h_call6,
  clear arg0 arg1 arg2,
  -- function call
  step_assert_eq hpc6 with arg0,
  step_assert_eq hpc7 hpc8 with arg1,
  step_sub hpc9 (auto_sound_assert_nn_le mem _ range_check_ptr₁ val.d1 (BASE - 1) _ _ _ _ _ _),
  { rw hpc10, norm_num2, exact h_mem_2 },
  { rw hpc10, norm_num2, exact h_mem_0 },
  { rw hpc10, norm_num2, exact h_mem_1 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call11 ap11 h_call11,
  rcases h_call11 with ⟨h_call11_ap_offset, h_call11⟩,
  rcases h_call11 with ⟨rc_m11, rc_mle11, hl_range_check_ptr₂, h_call11⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap11 - 1) = 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] at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0 ,arg1] at h_call11 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call11,
  clear arg0 arg1,
  -- function call
  step_assert_eq hpc11 with arg0,
  step_assert_eq hpc12 hpc13 with arg1,
  step_sub hpc14 (auto_sound_assert_nn_le mem _ range_check_ptr₂ val.d0 (BASE - 1) _ _ _ _ _ _),
  { rw hpc15, norm_num2, exact h_mem_2 },
  { rw hpc15, norm_num2, exact h_mem_0 },
  { rw hpc15, norm_num2, exact h_mem_1 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call16 ap16 h_call16,
  rcases h_call16 with ⟨h_call16_ap_offset, h_call16⟩,
  rcases h_call16 with ⟨rc_m16, rc_mle16, hl_range_check_ptr₃, h_call16⟩,
  generalize' hr_rev_range_check_ptr₃: mem (ap16 - 1) = 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] at hl_range_check_ptr₃ },
  rw [←htv_range_check_ptr₃, ←htv_range_check_ptr₂] at hl_range_check_ptr₃,
  try { simp only [arg0 ,arg1] at h_call16 },
  rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call16,
  clear arg0 arg1,
  -- if statement
  step_assert_eq hpc16 hpc17 with temp0,
  have htest: _ = val.d2 - P2, {
    apply eq.trans temp0,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
    try { dsimp [cast_BigInt3] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear temp0,
  step_jnz hpc18 hpc19 with hcond hcond,
  {
    -- if: positive branch
    have a16 := cond_aux1 htest hcond,
    try { arith_simps at a16 },
    clear htest hcond,
    -- if statement
    step_assert_eq hpc20 hpc21 with temp0,
    have htest: _ = val.d1 - P1, {
      apply eq.trans temp0,
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
      try { dsimp [cast_BigInt3] },
      try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    clear temp0,
    step_jnz hpc22 hpc23 with hcond hcond,
    {
      -- if: positive branch
      have a20 := cond_aux1 htest hcond,
      try { arith_simps at a20 },
      clear htest hcond,
      -- function call
      step_assert_eq hpc24 with arg0,
      step_assert_eq hpc25 with arg1,
      step_assert_eq hpc26 hpc27 with arg2,
      step_sub hpc28 (auto_sound_assert_nn_le mem _ range_check_ptr₃ val.d0 (P0 - 1) _ _ _ _ _ _),
      { rw hpc29, norm_num2, exact h_mem_2 },
      { rw hpc29, norm_num2, exact h_mem_0 },
      { rw hpc29, norm_num2, exact h_mem_1 },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      intros κ_call30 ap30 h_call30,
      rcases h_call30 with ⟨h_call30_ap_offset, h_call30⟩,
      rcases h_call30 with ⟨rc_m30, rc_mle30, hl_range_check_ptr₄, h_call30⟩,
      generalize' hr_rev_range_check_ptr₄: mem (ap30 - 1) = 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] 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] at h_call30 },
      rw [←htv_range_check_ptr₃, hl_range_check_ptr₃, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call30,
      clear arg0 arg1 arg2,
      -- return
      step_ret hpc30,
      -- finish
      step_done, use_only [rfl, rfl],
      -- range check condition
      use_only (rc_m6+rc_m11+rc_m16+rc_m30+0+0), split,
      linarith [rc_mle6, rc_mle11, rc_mle16, rc_mle30],
      split,
      { arith_simps,
        rw [←htv_range_check_ptr₄, hl_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_validate_reduced_field_element mem _ range_check_ptr val _,
      { apply sound_validate_reduced_field_element, apply auto_spec },
      -- prove the auto generated assertion
      dsimp [auto_spec_validate_reduced_field_element],
      try { norm_num1 }, try { arith_simps },
      use_only [κ_call6],
      use_only [range_check_ptr₁],
      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],
      use_only [κ_call11],
      use_only [range_check_ptr₂],
      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 spec11 := h_call11 rc_h_range_check_ptr₁',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec11,
      try { dsimp at spec11, arith_simps at spec11 },
      use_only [spec11],
      use_only [κ_call16],
      use_only [range_check_ptr₃],
      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 spec16 := h_call16 rc_h_range_check_ptr₂',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←htv_range_check_ptr₃] at spec16,
      try { dsimp at spec16, arith_simps at spec16 },
      use_only [spec16],
      left,
      use_only [a16],
      left,
      use_only [a20],
      use_only [κ_call30],
      use_only [range_check_ptr₄],
      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₁, ←hl_range_check_ptr₂, ←hl_range_check_ptr₃, ←htv_range_check_ptr₄] at spec30,
      try { dsimp at spec30, arith_simps at spec30 },
      use_only [spec30],
      try { split, linarith },
      try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃, htv_range_check_ptr₄] }, },
      try { dsimp [cast_BigInt3] },
      try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset, h_call30_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    },
    {
      -- if: negative branch
      have a20 := cond_aux2 htest hcond,
      try { arith_simps at a20 },
      clear htest hcond,
      -- function call
      step_assert_eq hpc31 with arg0,
      step_assert_eq hpc32 with arg1,
      step_assert_eq hpc33 hpc34 with arg2,
      step_sub hpc35 (auto_sound_assert_nn_le mem _ range_check_ptr₃ val.d1 (P1 - 1) _ _ _ _ _ _),
      { rw hpc36, norm_num2, exact h_mem_2 },
      { rw hpc36, norm_num2, exact h_mem_0 },
      { rw hpc36, norm_num2, exact h_mem_1 },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      intros κ_call37 ap37 h_call37,
      rcases h_call37 with ⟨h_call37_ap_offset, h_call37⟩,
      rcases h_call37 with ⟨rc_m37, rc_mle37, hl_range_check_ptr₄, h_call37⟩,
      generalize' hr_rev_range_check_ptr₄: mem (ap37 - 1) = 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] 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] at h_call37 },
      rw [←htv_range_check_ptr₃, hl_range_check_ptr₃, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call37,
      clear arg0 arg1 arg2,
      -- return
      step_ret hpc37,
      -- finish
      step_done, use_only [rfl, rfl],
      -- range check condition
      use_only (rc_m6+rc_m11+rc_m16+rc_m37+0+0), split,
      linarith [rc_mle6, rc_mle11, rc_mle16, rc_mle37],
      split,
      { arith_simps,
        rw [←htv_range_check_ptr₄, hl_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_validate_reduced_field_element mem _ range_check_ptr val _,
      { apply sound_validate_reduced_field_element, apply auto_spec },
      -- prove the auto generated assertion
      dsimp [auto_spec_validate_reduced_field_element],
      try { norm_num1 }, try { arith_simps },
      use_only [κ_call6],
      use_only [range_check_ptr₁],
      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],
      use_only [κ_call11],
      use_only [range_check_ptr₂],
      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 spec11 := h_call11 rc_h_range_check_ptr₁',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec11,
      try { dsimp at spec11, arith_simps at spec11 },
      use_only [spec11],
      use_only [κ_call16],
      use_only [range_check_ptr₃],
      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 spec16 := h_call16 rc_h_range_check_ptr₂',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←htv_range_check_ptr₃] at spec16,
      try { dsimp at spec16, arith_simps at spec16 },
      use_only [spec16],
      left,
      use_only [a16],
      right,
      use_only [a20],
      use_only [κ_call37],
      use_only [range_check_ptr₄],
      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 spec37 := h_call37 rc_h_range_check_ptr₃',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←hl_range_check_ptr₃, ←htv_range_check_ptr₄] at spec37,
      try { dsimp at spec37, arith_simps at spec37 },
      use_only [spec37],
      try { split, linarith },
      try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃, htv_range_check_ptr₄] }, },
      try { dsimp [cast_BigInt3] },
      try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset, h_call37_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    }
  },
  {
    -- if: negative branch
    have a16 := cond_aux2 htest hcond,
    try { arith_simps at a16 },
    clear htest hcond,
    -- return
    step_assert_eq hpc38 with hret0,
    step_ret hpc39,
    -- finish
    step_done, use_only [rfl, rfl],
    -- range check condition
    use_only (rc_m6+rc_m11+rc_m16+0+0), split,
    linarith [rc_mle6, rc_mle11, rc_mle16],
    split,
    { arith_simps, try { simp only [hret0] },
      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_validate_reduced_field_element mem _ range_check_ptr val _,
    { apply sound_validate_reduced_field_element, apply auto_spec },
    -- prove the auto generated assertion
    dsimp [auto_spec_validate_reduced_field_element],
    try { norm_num1 }, try { arith_simps },
    use_only [κ_call6],
    use_only [range_check_ptr₁],
    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],
    use_only [κ_call11],
    use_only [range_check_ptr₂],
    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 spec11 := h_call11 rc_h_range_check_ptr₁',
    rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec11,
    try { dsimp at spec11, arith_simps at spec11 },
    use_only [spec11],
    use_only [κ_call16],
    use_only [range_check_ptr₃],
    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 spec16 := h_call16 rc_h_range_check_ptr₂',
    rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←htv_range_check_ptr₃] at spec16,
    try { dsimp at spec16, arith_simps at spec16 },
    use_only [spec16],
    right,
    use_only [a16],
    try { split, linarith },
    try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] }, },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [hret0] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  }
end


import category_theory.limits.shapes.images
import algebraic_topology.simplex_category
import tactic.equiv_rw
import category_theory.limits.shapes.regular_mono

noncomputable theory
/-
universes u

namespace category_theory

lemma concrete_category.bijective_of_is_iso {C : Type*} [category C]
  [concrete_category C] {X Y : C} (f : X ⟶ Y) [is_iso f] :
  function.bijective ((forget _).map f) :=
by { rw ← is_iso_iff_bijective, apply_instance, }

lemma strong_epi_of_is_split_epi
  {C : Type*} [category C] {A B : C} (f : A ⟶ B) [is_split_epi f] : strong_epi f :=
strong_epi.mk' begin
  introsI X Y z hz u v sq,
  exact comm_sq.has_lift.mk'
  { l := section_ f ≫ u,
    fac_left' := by simp only [← cancel_mono z, sq.w, category.assoc, is_split_epi.id_assoc],
    fac_right' := by simp only [sq.w, category.assoc, is_split_epi.id_assoc], }
end

variables {C D : Type*} [category C] [category D] (F : C ⥤ D) {A B : C} (f : A ⟶ B)

namespace functor

def is_split_epi_iff [full F] [faithful F] : is_split_epi f ↔ is_split_epi (F.map f) :=
begin
  split,
  { intro h, refine is_split_epi.mk' ((split_epi_equiv F f).to_fun h.exists_split_epi.some), },
  { intro h, refine is_split_epi.mk' ((split_epi_equiv F f).inv_fun h.exists_split_epi.some), },
end

variable {F}
lemma strong_epi_imp_strong_epi_map_of_adjunction {F' : D ⥤ C} (adj : F ⊣ F') (f : A ⟶ B)
  [h₁ : preserves_monomorphisms F']
  [h₂ : preserves_epimorphisms F] :
  strong_epi f → strong_epi (F.map f) :=
begin
  introI hf,
  refine ⟨infer_instance, _⟩,
  intros X Y z,
  introI,
  rw has_lifting_property.iff_of_adjunction adj,
  apply_instance,
end

instance strong_epi_map_of_is_equivalence [is_equivalence F]
  [h : strong_epi f] : strong_epi (F.map f) :=
strong_epi_imp_strong_epi_map_of_adjunction ((as_equivalence F).to_adjunction) f h

lemma strong_epi.of_arrow_iso {A B A' B' : C} {f : A ⟶ B} {g : A' ⟶ B'}
  (e : arrow.mk f ≅ arrow.mk g) [h : strong_epi f] : strong_epi g :=
{ epi := begin
    haveI : epi (f ≫ (arrow.right_func.map_iso e).hom) := epi_comp _ _,
    have eq : g = (arrow.left_func.map_iso e).inv ≫ f ≫
      (arrow.right_func.map_iso e).hom,
    { have eq' := arrow.hom.congr_right e.inv_hom_id,
      dsimp at eq',
      simp only [map_iso_inv, arrow.left_func_map, map_iso_hom,
        arrow.right_func_map, arrow.w_mk_right_assoc, arrow.mk_hom, eq'],
      dsimp,
      simp only [category.comp_id], },
    rw eq,
    apply epi_comp,
  end,
  llp := λ X Y z, begin
    introI,
    apply has_lifting_property.of_arrow_iso_left e z,
  end }

lemma strong_epi_iff_of_arrow_iso {A B A' B' : C} {f : A ⟶ B} {g : A' ⟶ B'}
  (e : arrow.mk f ≅ arrow.mk g) : strong_epi f ↔ strong_epi g :=
by { split; introI, exacts [strong_epi.of_arrow_iso e, strong_epi.of_arrow_iso e.symm], }

def arrow.iso_of_nat_iso {C D : Type*} [category C] [category D]
  {F G : C ⥤ D} (e : F ≅ G) (f : arrow C) :
  F.map_arrow.obj f ≅ G.map_arrow.obj f :=
arrow.iso_mk (e.app f.left) (e.app f.right) (by simp)

variable (F)
lemma strong_epi_iff_strong_epi_map_of_is_equivalence [is_equivalence F] :
  strong_epi f ↔ strong_epi (F.map f) :=
begin
  split,
  { introI,
    apply_instance, },
  { introI,
    have e : arrow.mk f ≅ arrow.mk (F.inv.map (F.map f)) :=
      arrow.iso_of_nat_iso (F.as_equivalence.unit_iso) (arrow.mk f),
    rw strong_epi_iff_of_arrow_iso e,
    apply_instance, }
end

open limits

def preimage_strong_epi_mono_factorisation (s : strong_epi_mono_factorisation (F.map f))
  [is_equivalence F] :
  strong_epi_mono_factorisation f :=
begin
  haveI : mono (F.preimage (F.as_equivalence.counit_iso.hom.app _ ≫ s.m)),
  { simp only [← F.mono_map_iff_mono, as_equivalence_counit, image_preimage],
    apply mono_comp, },
  haveI : strong_epi (F.preimage (s.e ≫ F.as_equivalence.counit_iso.inv.app _)),
  { simp only [← @strong_epi_map_iff_strong_epi_of_is_equivalence _ _ _ _ F,
      image_preimage, as_equivalence_counit],
    apply strong_epi_comp, },
  exact
  { I := F.inv.obj s.I,
    m := F.preimage (F.as_equivalence.counit_iso.hom.app _ ≫ s.m),
    e := F.preimage (s.e ≫ F.as_equivalence.counit_iso.inv.app _),
    m_mono := infer_instance,
    fac' := begin
      apply F.map_injective,
      simp only [map_comp, image_preimage, category.assoc, iso.inv_hom_id_app_assoc,
        mono_factorisation.fac],
    end, }
end

lemma has_strong_epi_mono_factorisations_imp [is_equivalence F]
  [h : has_strong_epi_mono_factorisations D] :
  has_strong_epi_mono_factorisations C :=
⟨λ X Y f, begin
  apply nonempty.intro,
  apply F.preimage_strong_epi_mono_factorisation,
  let H := h.has_fac,
  exact (H (F.map f)).some,
end⟩

end functor

end category_theory

open category_theory

namespace simplex_category

lemma skeletal_equivalence.functor.map_eq
  {Δ₁ Δ₂ : simplex_category} (f : Δ₁ ⟶ Δ₂) :
  coe_fn (simplex_category.skeletal_equivalence.{u}.functor.map f) =
    ulift.up ∘ f.to_order_hom ∘ ulift.down := rfl

lemma skeletal_equivalence.functor.surjective_iff_map
  {Δ₁ Δ₂ : simplex_category} (f : Δ₁ ⟶ Δ₂) :
  function.surjective f.to_order_hom ↔
  function.surjective
  (simplex_category.skeletal_equivalence.{u}.functor.map f) :=
by rw [skeletal_equivalence.functor.map_eq,
    function.surjective.of_comp_iff' ulift.up_bijective, function.surjective.of_comp_iff _ ulift.down_surjective]

lemma skeletal_equivalence.functor.injective_iff_map
  {Δ₁ Δ₂ : simplex_category} (f : Δ₁ ⟶ Δ₂) :
  function.injective f.to_order_hom ↔
  function.injective
  (simplex_category.skeletal_equivalence.{u}.functor.map f) :=
by rw [skeletal_equivalence.functor.map_eq, function.injective.of_comp_iff ulift.up_injective,
  function.injective.of_comp_iff' _ ulift.down_bijective]

end simplex_category

namespace NonemptyFinLinOrd

lemma epi_iff_surjective {A B : NonemptyFinLinOrd.{u}} (f : A ⟶ B) :
  epi f ↔ function.surjective f :=
begin
  have eq := simplex_category.skeletal_equivalence.counit_iso.hom.naturality f,
  simp only [← cancel_mono (simplex_category.skeletal_equivalence.counit_iso.inv.app B),
    category.assoc, iso.hom_inv_id_app, category.comp_id, functor.id_map] at eq,
  rw [← simplex_category.skeletal_equivalence.inverse.epi_map_iff_epi,
    simplex_category.epi_iff_surjective,
    simplex_category.skeletal_equivalence.functor.surjective_iff_map,
    ← functor.comp_map, eq, coe_comp, coe_comp,
    function.surjective.of_comp_iff, function.surjective.of_comp_iff'],
  { apply concrete_category.bijective_of_is_iso, },
  { apply function.bijective.surjective,
    apply concrete_category.bijective_of_is_iso, },
end

instance : split_epi_category NonemptyFinLinOrd.{u} :=
⟨λ X Y f hf, begin
  have H : ∀ (y : Y), nonempty (f⁻¹' { y }),
  { rw epi_iff_surjective at hf,
    intro y,
    exact nonempty.intro ⟨(hf y).some, (hf y).some_spec⟩, },
  let φ : Y → X := λ y, (H y).some.1,
  have hφ : ∀ (y : Y), f (φ y) = y := λ y, (H y).some.2,
  refine is_split_epi.mk' ⟨⟨φ, _⟩, _⟩, swap,
  { ext b,
    apply hφ, },
  { intros a b,
    contrapose,
    intro h,
    simp only [not_le] at h ⊢,
    suffices : b ≤ a,
    { cases this.lt_or_eq with h₁ h₂,
      { assumption, },
      { exfalso,
        simpa only [h₂, lt_self_iff_false] using h, }, },
    simpa only [hφ] using f.monotone (le_of_lt h), },
end⟩

lemma mono_iff_injective {A B : NonemptyFinLinOrd.{u}} {f : A ⟶ B} :
  mono f ↔ function.injective f :=
begin
  have eq := simplex_category.skeletal_equivalence.counit_iso.hom.naturality f,
  simp only [← cancel_mono (simplex_category.skeletal_equivalence.counit_iso.inv.app B),
    category.assoc, iso.hom_inv_id_app, category.comp_id, functor.id_map] at eq,
  rw [← simplex_category.skeletal_equivalence.inverse.mono_map_iff_mono,
    simplex_category.mono_iff_injective,
    simplex_category.skeletal_equivalence.functor.injective_iff_map,
    ← functor.comp_map, eq, coe_comp, coe_comp,
    function.injective.of_comp_iff', function.injective.of_comp_iff],
  { apply function.bijective.injective,
    apply concrete_category.bijective_of_is_iso, },
  { apply concrete_category.bijective_of_is_iso, },
end

@[protected, simps]
def strong_epi_mono_factorisation {X Y : NonemptyFinLinOrd.{u}} (f : X ⟶ Y) :
  limits.strong_epi_mono_factorisation f :=
begin
  let I : NonemptyFinLinOrd.{u} := ⟨set.image (coe_fn f) ⊤, ⟨⟩⟩,
  let e : X ⟶ I := ⟨λ x, ⟨f x, ⟨x, by tidy⟩⟩, λ x₁ x₂ h, f.monotone h⟩,
  let m : I ⟶ Y := ⟨λ y, y, by tidy⟩,
  haveI : epi e,
  { rw epi_iff_surjective, tidy, },
  haveI : strong_epi e := strong_epi_of_epi e,
  haveI : mono m,
  { rw mono_iff_injective, tidy, },
  exact
  { I := I,
    m := m,
    e := e, },
end

instance : limits.has_strong_epi_mono_factorisations NonemptyFinLinOrd.{u} :=
⟨λ X Y f, nonempty.intro (NonemptyFinLinOrd.strong_epi_mono_factorisation f)⟩

end NonemptyFinLinOrd

namespace simplex_category

open category_theory.limits

instance : split_epi_category simplex_category :=
⟨λ X Y f, begin
  introI,
  rw ← simplex_category.skeletal_equivalence.{0}.functor.is_split_epi_iff,
  apply is_split_epi_of_epi,
end⟩

@[protected]
lemma has_strong_epi_mono_factorisations : has_strong_epi_mono_factorisations simplex_category :=
simplex_category.skeletal_functor.has_strong_epi_mono_factorisations_imp.{0}

attribute [instance] has_strong_epi_mono_factorisations

lemma image_eq {Δ Δ' Δ'' : simplex_category } {φ : Δ ⟶ Δ''}
  {e : Δ ⟶ Δ'} [epi e] {i : Δ' ⟶ Δ''} [mono i] (fac : e ≫ i = φ) :
  image φ = Δ' :=
begin
  haveI := strong_epi_of_epi e,
  let eq := image.iso_strong_epi_mono e i fac,
  ext,
  apply le_antisymm,
  { exact @len_le_of_epi  _ _ eq.hom infer_instance, },
  { exact @len_le_of_mono  _ _ eq.hom infer_instance, },
end

lemma image_ι_eq {Δ Δ'' : simplex_category } {φ : Δ ⟶ Δ''}
  {e : Δ ⟶ image φ} [epi e] {i : image φ ⟶ Δ''} [mono i] (fac : e ≫ i = φ) :
  image.ι φ = i :=
begin
  haveI := strong_epi_of_epi e,
  rw ← image.iso_strong_epi_mono_hom_comp_ι e i fac,
  conv_lhs { rw ← category.id_comp (image.ι φ), },
  congr,
  symmetry,
  apply simplex_category.eq_id_of_is_iso,
  apply_instance,
end

lemma factor_thru_image_eq {Δ Δ'' : simplex_category } {φ : Δ ⟶ Δ''}
  {e : Δ ⟶ image φ} [epi e] {i : image φ ⟶ Δ''} [mono i] (fac : e ≫ i = φ) :
  factor_thru_image φ = e :=
by rw [← cancel_mono i, fac, ← image_ι_eq fac, image.fac]

end simplex_category
-/


import .refinement.one_to_one

universe variables u u₀ u₁ u₂

namespace temporal
namespace feasibility
open fairness predicate nat
local infix ` ≃ `:75 := v_eq
section feasibility

parameters {α : Type u}
parameters {evt : Type u₂}
parameters {p : pred' α}
parameters (A : evt → act α)
parameters {cs₀ fs₀ : evt → pred' α}
parameters (J : pred' α)
parameters [inhabited evt] [inhabited α]

parameter init_FIS : ∃ s, s ⊨ p
parameter init_INV : ∀ s, s ⊨ p → s ⊨ J
parameter DLF : ∀ s, s ⊨ J → ∃ e, s ⊨ cs₀ e ∧ s ⊨ fs₀ e
parameter evt_FIS : ∀ e s, s ⊨ J → s ⊨ cs₀ e → s ⊨ fs₀ e → ∃ s', A e s s'
parameter evt_INV : ∀ e s s', A e s s' → s ⊨ J → s' ⊨ J

def SPEC₀ (v : tvar α) : cpred :=
spec p cs₀ fs₀ A v

def p' : pred' (unit × α) :=
p ! pair.snd

def q' : pred' (unit × unit) :=
True

open prod
def A' (e : evt) : act (unit × α) :=
λ σ σ',
     (A e on snd) σ σ'

def C (e : evt) : act (unit × unit) :=
λ _ _, true

def C' (e : evt) : act (evt × unit × unit) :=
λ ⟨sch,_⟩ _, sch = e

abbreviation J' : pred' (unit × α × unit) :=
J ! pair.fst ! pair.snd

abbreviation cs₀' (e : evt) : pred' (unit × α) :=
cs₀ e ! pair.snd

abbreviation fs₀' (e : evt) : pred' (unit × α) :=
fs₀ e ! pair.snd

abbreviation cs₁ (e : evt) : pred' (unit × unit) :=
True

abbreviation fs₁ (e : evt) : pred' (unit × unit) :=
True
section
include init_FIS init_INV DLF
lemma SIM₀' (v o : unit)
  (h : (o, v) ⊨ q')
: (∃ (w : α), (o, w) ⊨ p' ∧ (o, w, v) ⊨ J') :=
by { simp [q',p'] at *,
     apply exists_imp_exists _ init_FIS,
     intros, split, assumption, apply init_INV, assumption }
end
open function
section
include evt_FIS evt_INV DLF
lemma SIM' (w : α) (v o v' o' : unit) (e : evt)
  (hJ : (o, w, v) ⊨ J')
  (_ : true)
  (_ : true)
  (_ : true)
  (hC : C e (o, v) (o', v'))
: (∃ (w' : α),
        (o,w) ⊨ cs₀' e ∧
        (o,w) ⊨ fs₀' e ∧
        A' e (o, w) (o', w') ∧
        (o', w', v') ⊨ J') :=
begin
  -- simp [comp,A',on_fun] at *,
  -- casesm* [_ ∧ _, Exists _, unit],
  -- constructor_matching* [_ ∧ _],
  -- apply exists_imp_exists _ (evt_FIS e w _),
  -- intros, split, admit, assumption,
  -- tauto,
  admit,
end

end

def o : tvar unit := ↑()

-- parameter Hpo
-- : ∀ c a e, one_to_one_po' (SPEC₀.saf a o ⋀ ◻(J ! ⦃o,a,c⦄))
--          ⟨cs₁ e,fs₁ e,C' e⟩
--          ⟨cs₀ e,fs₀ e,A' e⟩ ⦃o,c⦄ ⦃o,a⦄)

def SPEC₀.saf' (v : tvar α) (sch : tvar evt) : cpred :=
spec_saf_spec p' cs₀' fs₀' A' ⦃o,v⦄ sch

def SPEC₁ (v : tvar unit) : cpred :=
spec q' cs₁ fs₁ C ⦃o,v⦄

lemma Hpo'
 : ∀ c a e sch, one_to_one_po' (SPEC₁ c ⋀ SPEC₀.saf' a sch ⋀ ◻(J' ! ⦃o,a,c⦄))
         ⟨cs₁ e!pair.snd,fs₁ e!pair.snd,one_to_one.C' C e⟩
         ⟨cs₀' e,fs₀' e,A' e⟩ ⦃sch,o,c⦄ ⦃o,a⦄ :=
begin
  intros,
  constructor,
  { simp [tl_leads_to], },
  { simp [tl_leads_to], },
  { simp [tl_leads_to], },
  begin [temporal]
    simp [SPEC₁,q',sched,SPEC₀.saf'],
    intros _ _ _ h _, henceforth! at *,
    intros, cases h with x h,
    explicit' [C,one_to_one.C',A']
      with h a_3
    { cc },
  end,
end

include J init_INV init_FIS evt_INV evt_FIS Hpo' DLF
lemma feasibility [schedulable evt]
: ⊩ (∃∃ v, SPEC₀ v) :=
begin [temporal]
  have := temporal.feasibility.SIM',
  have :=  @one_to_one.refinement α unit unit evt
     temporal.feasibility.p' temporal.feasibility.q'
       temporal.feasibility.A'
       temporal.feasibility.C
       temporal.feasibility.cs₀'
       temporal.feasibility.fs₀'
       temporal.feasibility.cs₁
       temporal.feasibility.fs₁
       temporal.feasibility.J' True _ _
       _ _
       temporal.feasibility.SIM₀'
       temporal.feasibility.SIM'
       o _ _ Γ _,
  { simp [one_to_one.SPEC₀,SPEC₀] at this ⊢,
    casesm* [p_exists _, _ ⋀ _],
    existsi _, solve_by_elim,
    split,
    { simp [A',p',action_on' _ _ prod.snd] at *,
      tauto, },
    { simp [A',action_on' _ _ prod.snd] at *,
      assumption, }, },
  { intros, simp, },
  { intros, simp, },
  apply temporal.feasibility.Hpo' ,
  { existsi o,
    simp [one_to_one.SPEC₁,q',C,C',sched], }
end

end feasibility
end feasibility
end temporal


import tactic
import data.finsupp.basic
import control.bifunctor
import verification.misc
import verification.semantics.stream_props
import verification.semantics.finsuppeval

open_locale classical
noncomputable theory

variables {ι : Type} {α : Type*}
[linear_order ι]

@[mk_iff]
structure Stream.mul.ready {ι : Type} (a : Stream ι α) (b : Stream ι α) (s : a.σ × b.σ) : Prop :=
(v₁ : a.valid s.1)
(v₂ : b.valid s.2)
(r₁ : a.ready s.1)
(r₂ : b.ready s.2)
(index : a.index s.1 v₁ = b.index s.2 v₂)

section defs
variables [has_mul α]

@[simps]
instance : has_mul (Stream ι α) := ⟨λ (a b : Stream ι α),
{ σ := a.σ × b.σ,
  valid := λ p, a.valid p.1 ∧ b.valid p.2,
  ready := λ p, Stream.mul.ready a b p,
  next  := λ p hv,
  if a.to_order p.1 ≤ b.to_order p.2 then
    (a.next p.1 hv.1, p.2)
  else (p.1, b.next p.2 hv.2),
  index := λ p hv, max (a.index p.1 hv.1) (b.index p.2 hv.2),
  value := λ p hr, a.value p.1 hr.r₁ * b.value p.2 hr.r₂ }⟩

end defs

section index_lemmas
variables [has_mul α]

lemma Stream.mul.ready.index' {a : Stream ι α} {b : Stream ι α} {x y} (h : (a * b).ready (x, y)) :
  a.index' x = b.index' y :=
by simp [Stream.index'_val h.v₁, Stream.index'_val h.v₂, h.index]

lemma Stream.mul.ready.order_eq {a : Stream ι α} {b : Stream ι α} {x y} (h : (a * b).ready (x, y)) :
  a.to_order x = b.to_order y :=
by ext : 1; simp [h.r₁, h.r₂, h.index']

lemma Stream.mul_index' (a : Stream ι α) (b : Stream ι α) (xy : a.σ × b.σ) :
  (a * b).index' xy = max (a.index' xy.1) (b.index' xy.2) :=
begin
  cases xy with x y,
  rw [Stream.index'], simp, split_ifs with h,
  { simp [Stream.index'_val h.1, Stream.index'_val h.2], },
  rw not_and_distrib at h, cases h; simp [Stream.index'_invalid h],
end

end index_lemmas

section value_lemmas

variables [non_unital_non_assoc_semiring α]

lemma Stream.mul_eval₀_of_neq {a : Stream ι α} {b : Stream ι α} {x y} (h : a.to_order x ≠ b.to_order y) (H) :
  (a * b).eval₀ (x, y) H = 0 :=
by { contrapose! h, apply Stream.mul.ready.order_eq, simp [Stream.eval₀] at h, exact h.fst, }

lemma Stream.mul_eval₀ (a : Stream ι α) (b : Stream ι α) (x : a.σ) (y : b.σ) (H) :
  (a * b).eval₀ (x, y) H = (a.eval₀ x H.1) * (b.eval₀ y H.2) :=
begin
  rw [Stream.eval₀], split_ifs with hr,
  { simp [Stream.eval₀, hr.r₁, hr.r₂, hr.index], },
  simp [Stream.mul.ready_iff, H.1, H.2] at hr,
  simp [Stream.eval₀], split_ifs with h₁ h₂; try { simp },
  rw finsupp.mul_single_eq_zero _ _ (hr h₁ h₂),
end

/-- This lemma states that if `a.to_order x ≤ b.to_order y`,
  then the support of `a.eval₀ x h₁` (which is at most `{a.index x}`)
  is disjoint from `b.eval_steps n (b.next y)`, assuming `b` is simple. -/
lemma Stream.mul_eq_zero_aux {a : Stream ι α} {b : Stream ι α} (hb : b.simple) {x : a.σ} {y : b.σ}
  (h₁ : a.valid x) (h₂ : b.valid y) (H : a.to_order x ≤ b.to_order y) (n : ℕ) :
  disjoint (a.eval₀ x h₁).support (b.eval_steps n (b.next y h₂)).support :=
begin
  -- Assume `a` is ready, or else `a.eval₀ x h₁ = 0` has trivial support.
  by_cases hr : a.ready x, swap, { simp [Stream.eval₀, hr], },
  rw finset.disjoint_iff_ne,
  intros i₁ hi₁ i₂ hi₂,
  cases finset.mem_singleton.mp (a.eval₀_support _ _ hi₁),
  rw le_iff_eq_or_lt at H,
  refine ne_of_lt (with_top.coe_lt_coe.mp _), rw ← Stream.index'_val h₁,
  cases H,
  { -- `a.to_order x = b.to_order y`
    simp [prod.ext_iff, hr] at H,
    rw H.1,
    exact hb.index_lt_support h₂ H.2 _ hi₂, },
  -- Case `a < b`
  refine lt_of_lt_of_le (prod.lex.fst_lt_of_lt_of_le H (by simp [hr])) _,
  exact (hb.monotonic h₂).trans (hb.monotonic.index_le_support _ hi₂),
end

lemma Stream.mul_eq_zero {a : Stream ι α} {b : Stream ι α} (hb : b.simple) {x : a.σ} {y : b.σ}
  (h₁ : a.valid x) (h₂ : b.valid y) (H : a.to_order x ≤ b.to_order y) (n : ℕ) :
  a.eval₀ x h₁ * b.eval_steps n (b.next y h₂) = 0 :=
by { rw [finsupp.mul_eq_zero_of_disjoint_support], exact Stream.mul_eq_zero_aux hb h₁ h₂ H n, }

lemma Stream.mul_eq_zero' {a : Stream ι α} {b : Stream ι α} (ha : a.simple) {x : a.σ} {y : b.σ}
  (h₁ : a.valid x) (h₂ : b.valid y) (H : b.to_order y ≤ a.to_order x) (n : ℕ) :
  a.eval_steps n (a.next x h₁) * b.eval₀ y h₂ = 0 :=
by { rw [finsupp.mul_eq_zero_of_disjoint_support], exact (Stream.mul_eq_zero_aux ha h₂ h₁ H n).symm, }

end value_lemmas

@[elab_as_eliminator]
theorem Stream.mul_induction [has_mul α] {a : Stream ι α} {b : Stream ι α} {x : a.σ} {y : b.σ}
  {B₁ B₂ : ℕ} (ha : a.bound_valid B₁ x) (hb : b.bound_valid B₂ y)
  (P : ∀ (x : a.σ) (y : b.σ) (k₁ : ℕ) (k₂ : ℕ) (N : ℕ), Prop)
  (hP_base : ∀ (x y), P x y 0 0 0)
  (hP_invalid : ∀ (x y B₁ B₂ N) (H : ¬(a * b).valid (x, y)) (hvx : ¬a.valid x ∨ ¬b.valid y), a.bound_valid B₁ x → b.bound_valid B₂ y → P x y B₁ B₂ N)
  (hP_advance_a : ∀ (x y k₁ k₂ N) (H : (a * b).valid (x, y)), a.to_order x ≤ b.to_order y → P (a.next x H.1) y k₁ (k₂ + 1) N → P x y (k₁ + 1) (k₂ + 1) (N + 1))
  (hP_advance_b : ∀ (x y k₁ k₂ N) (H : (a * b).valid (x, y)), b.to_order y < a.to_order x → P x (b.next y H.2) (k₁ + 1) k₂ N → P x y (k₁ + 1) (k₂ + 1) (N + 1)) :
  P x y B₁ B₂ (B₁ + B₂) :=
begin
  suffices : ∀ n, n = B₁ + B₂ → ∃ (k₁ k₂ : ℕ), k₁ ≤ B₁ ∧ k₂ ≤ B₂ ∧ n = k₁ + k₂ ∧ P x y k₁ k₂ n,
  { obtain ⟨k₁, k₂, hk₁, hk₂, hn, he⟩ := this (B₁ + B₂) rfl,
    obtain ⟨rfl, rfl⟩ : k₁ = B₁ ∧ k₂ = B₂ := by split; linarith only [hk₁, hk₂, hn],
    exact he, },
  intros n hn,
  induction n with n ih generalizing B₁ B₂ x y,
  { use [0, 0], simpa using hP_base x y, },
  by_cases H : (a * b).valid (x, y), swap,
  { refine ⟨B₁, B₂, rfl.le, rfl.le, hn, hP_invalid _ _ _ _ _ H _ ha hb⟩,
    simpa [not_and_distrib] using H, },
  cases B₁, { cases H.1.bound_pos ha, },
  cases B₂, { cases H.2.bound_pos hb, },
  simp [nat.succ_eq_add_one, ← add_assoc] at hn,
  by_cases h : a.to_order x ≤ b.to_order y,
  { -- Advance `a` (i.e. `a` ≤ `b`)
    rw [Stream.bound_valid_succ] at ha,
    obtain ⟨k₁, k₂, hk₁, hk₂, rfl, he⟩ := ih (ha H.1) hb (hn.trans (add_right_comm _ _ _)),
    refine ⟨k₁ + 1, k₂, nat.succ_le_succ hk₁, hk₂, (add_right_comm k₁ k₂ 1), _⟩,
    cases k₂, { exfalso, linarith only [hn, hk₁], },
    apply hP_advance_a _ _ _ _ _ H h he, },
  { -- Advance `b` (i.e. `b < a`)
    rw [Stream.bound_valid_succ] at hb,
    obtain ⟨k₁, k₂, hk₁, hk₂, rfl, he⟩ := ih ha (hb H.2) hn,
    refine ⟨k₁, k₂ + 1, hk₁, nat.succ_le_succ  hk₂, rfl, _⟩,
    cases k₁, { exfalso, linarith only [hn, hk₂], },
    apply hP_advance_b _ _ _ _ _ H (lt_of_not_le h) he, }
end

theorem Stream.mul_spec_value [non_unital_non_assoc_semiring α] {a : Stream ι α} {b : Stream ι α} (hsa : a.simple) (hsb : b.simple)
  {x y B₁ B₂} (ha : a.bound_valid B₁ x) (hb : b.bound_valid B₂ y) :
  (a * b).eval_steps (B₁ + B₂) (x, y) = (a.eval_steps B₁ x) * (b.eval_steps B₂ y) :=
begin
  apply Stream.mul_induction ha hb (λ x y k₁ k₂ N, (a * b).eval_steps N (x, y) = (a.eval_steps k₁ x) * (b.eval_steps k₂ y)); clear_except hsa hsb,
  { intros, simp, },
  { intros x y B₁ B₂ N H h ha hb,
    cases h; simp [H, Stream.eval_invalid h, Stream.eval_invalid H], },
  { intros x y k₁ k₂ n H h he,
    simp [H, H.1, h, he, add_mul], congr,
    simp [H.2, mul_add, Stream.mul_eq_zero hsb H.1 H.2 h, Stream.mul_eval₀], },
  { intros x y k₁ k₂ n H h he,
    simp [H, H.2, h.not_le, he, mul_add], congr,
    simp [H.1, add_mul, Stream.mul_eval₀, Stream.mul_eq_zero' hsa H.1 H.2 h.le], },
end

theorem Stream.mul_spec_index [has_mul α] {a : Stream ι α} {b : Stream ι α}
  {x y B₁ B₂} (ha : a.bound_valid B₁ x) (hb : b.bound_valid B₂ y) :
  ((a * b).valid ((a * b).next'^[B₁ + B₂] (x, y)) → ((a * b).next'^[B₁ + B₂] (x, y)) = (a.next'^[B₁] x, b.next'^[B₂] y)) :=
begin
  apply Stream.mul_induction ha hb (λ x y k₁ k₂ N, (a * b).valid ((a * b).next'^[N] (x, y)) → ((a * b).next'^[N] (x, y)) = (a.next'^[k₁] x, b.next'^[k₂] y)); clear_except hsa hsb,
  { intros, simp, },
  { intros x y B₁ B₂ N H h ha hb, simp only [Stream.next'_val_invalid' H], exact false.elim ∘ H, },
  { intros x y k₁ k₂ n H h hiter,
    simp only [Stream.next'_val H, function.iterate_succ_apply, Stream.has_mul_mul_next, h, if_true, Stream.next'_val H.1],
    exact hiter, },
  { intros x y k₁ k₂ n H h hiter,
    simp only [Stream.next'_val H, function.iterate_succ_apply, Stream.has_mul_mul_next, h.not_le, if_false, Stream.next'_val H.2],
    exact hiter, },
end

@[simps]
instance {ι : Type} {α : Type*} [linear_order ι] [has_mul α] : has_mul (StreamExec ι α) := ⟨λ a b,
{ stream := a.stream * b.stream,
  state := (a.state, b.state),
  bound := a.bound + b.bound,
  bound_valid := begin
    rw [bound_valid_iff_next'_iterate],
    intro H,
    have := Stream.mul_spec_index a.bound_valid b.bound_valid H,
    dsimp at H, simp [this] at H,
    -- In fact, either `a` or `b` having a valid bound makes `a * b` have a valid bound
    -- We make an arbitrary choice here to use `a`
    refine absurd H.1 _,
    rw [← bound_valid_iff_next'_iterate],
    exact a.bound_valid,
  end }⟩

lemma StreamExec.mul_spec [non_unital_non_assoc_semiring α] (a : StreamExec ι α) (b : StreamExec ι α) (ha : a.stream.simple) (hb : b.stream.simple) :
  (a * b).eval = a.eval * b.eval := Stream.mul_spec_value ha hb a.bound_valid b.bound_valid

lemma Stream.mul_is_monotonic [has_mul α] {a : Stream ι α} {b : Stream ι α} (hsa : a.monotonic) (hsb : b.monotonic) :
  (a * b).monotonic :=
begin
  rintros ⟨x, y⟩ H,
  simp only [Stream.mul_index'],
  refine max_le_max _ _; simp; split_ifs,
  any_goals { exact rfl.le, },
  exacts [hsa _, hsb _],
end

lemma Stream.mul_is_simple [has_mul α] {a : Stream ι α} {b : Stream ι α} (hsa : a.simple) (hsb : b.simple) :
  (a * b).simple :=
begin
  refine ⟨Stream.mul_is_monotonic hsa.monotonic hsb.monotonic, _⟩,
  rintros ⟨x, y⟩ hv hr,
  simp only [Stream.mul_index', hr.index', max_self, Stream.has_mul_mul_next],
  split_ifs with H,
  { simp only [← hr.index', ne, max_ne_self_iff'], exact hsa.index_lt_next _ hr.r₁, },
  { simp only [hr.index', ne, max_ne_self_iff], exact hsb.index_lt_next _ hr.r₂, },
end

@[simps]
instance {ι : Type} {α : Type*} [linear_order ι] [has_mul α] : has_mul (SimpleStream ι α) := ⟨λ a b,
{ simple := Stream.mul_is_simple a.simple b.simple,
  ..(@has_mul.mul (StreamExec ι α) _ a b) }⟩

lemma SimpleStream.coe_mul {ι : Type} {α : Type*} [linear_order ι] [has_mul α] (a b : SimpleStream ι α) :
  (↑(a * b) : StreamExec ι α) = (↑a) * (↑b) := rfl

instance SimpleStream.MulEval [non_unital_non_assoc_semiring α] : MulEval (SimpleStream ι α) ι α :=
{ hmul := λ a b, StreamExec.mul_spec a b a.simple b.simple  }

section

lemma mul_value_eval {ι α ι' α' : Type*} [linear_order ι] [non_unital_non_assoc_semiring α'] [MulEval α ι' α']
  (a b : StreamExec ι α) :
  (Eval.eval <$₂> (a * b)) = (Eval.eval <$₂> a) * (Eval.eval <$₂> b) :=
begin
  ext; solve_refl,
  { simp only [Stream.mul.ready_iff], refl, },
  { simp, refl, },
end

-- huh??
instance {ι α ι' α' : Type*} [linear_order ι] [non_unital_non_assoc_semiring α'] [MulEval α ι' α'] :
  Eval (SimpleStream ι α) ι (ι' →₀ α') := SimpleStream.Eval_ind

instance {ι α ι' α' : Type*} [linear_order ι] [non_unital_non_assoc_semiring α'] [MulEval α ι' α'] :
  MulEval (SimpleStream ι α) ι (ι' →₀ α') :=
{ hmul := λ x y, by { simp [Eval.eval, mul_value_eval, SimpleStream.coe_mul], rw StreamExec.mul_spec, exacts [⟨x.monotonic, x.reduced⟩, ⟨y.monotonic, y.reduced⟩], } }

end


import for_mathlib.category_theory.triangulated.yoneda
import for_mathlib.category_theory.triangulated.triangles
import category_theory.triangulated.triangulated

noncomputable theory

namespace category_theory

open limits category preadditive triangulated
open_locale zero_object

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

namespace triangulated

open pretriangulated

variables {X₁ X₂ X₃ Z₁₂ Z₂₃ Z₁₃ : C} (u₁₂ : X₁ ⟶ X₂) (u₂₃ : X₂ ⟶ X₃) (u₁₃ : X₁ ⟶ X₃)
  (comm : u₁₂ ≫ u₂₃ = u₁₃)
  {v₁₂ : X₂ ⟶ Z₁₂} {w₁₂ : Z₁₂ ⟶ X₁⟦(1 : ℤ)⟧} (h₁₂ : triangle.mk u₁₂ v₁₂ w₁₂ ∈ dist_triang C)
  {v₂₃ : X₃ ⟶ Z₂₃} {w₂₃ : Z₂₃ ⟶ X₂⟦(1 : ℤ)⟧} (h₂₃ : triangle.mk u₂₃ v₂₃ w₂₃ ∈ dist_triang C)
  {v₁₃ : X₃ ⟶ Z₁₃} {w₁₃ : Z₁₃ ⟶ X₁⟦(1 : ℤ)⟧} (h₁₃ : triangle.mk u₁₃ v₁₃ w₁₃ ∈ dist_triang C)

lemma octahedron.of_iso {X₁' X₂' X₃' Z₁₂' Z₂₃' Z₁₃' : C} (u₁₂' : X₁' ⟶ X₂') (u₂₃' : X₂' ⟶ X₃')
  (e₁ : X₁ ≅ X₁') (e₂ : X₂ ≅ X₂')(e₃ : X₃ ≅ X₃')
  (comm₁₂ : u₁₂ ≫ e₂.hom = e₁.hom ≫ u₁₂') (comm₂₃ : u₂₃ ≫ e₃.hom = e₂.hom ≫ u₂₃')
  (v₁₂' : X₂' ⟶ Z₁₂') (w₁₂' : Z₁₂' ⟶ X₁'⟦(1 : ℤ)⟧)
  (h₁₂' : triangle.mk u₁₂' v₁₂' w₁₂' ∈ dist_triang C)
  (v₂₃' : X₃' ⟶ Z₂₃') (w₂₃' : Z₂₃' ⟶ X₂'⟦(1 : ℤ)⟧)
  (h₂₃' : triangle.mk u₂₃' v₂₃' w₂₃' ∈ dist_triang C)
  (v₁₃' : X₃' ⟶ Z₁₃') (w₁₃' : Z₁₃' ⟶ X₁'⟦(1 : ℤ)⟧)
  (h₁₃' : triangle.mk (u₁₂' ≫ u₂₃') v₁₃' w₁₃' ∈ dist_triang C)
  (H : octahedron rfl h₁₂' h₂₃' h₁₃') : octahedron comm h₁₂ h₂₃ h₁₃ :=
begin
  let iso₁₂ := iso_triangle_of_distinguished_of_is_iso₁₂ _ _ h₁₂ h₁₂' e₁ e₂ comm₁₂,
  let iso₂₃ := iso_triangle_of_distinguished_of_is_iso₁₂ _ _ h₂₃ h₂₃' e₂ e₃ comm₂₃,
  let iso₁₃ := iso_triangle_of_distinguished_of_is_iso₁₂ _ _ h₁₃ h₁₃' e₁ e₃
    (by { dsimp, simp only [← comm, assoc, comm₂₃, reassoc_of comm₁₂], }),
  have eq₁₂ := iso₁₂.hom.comm₂,
  have eq₁₂' := iso₁₂.hom.comm₃,
  have eq₁₃ := iso₁₃.hom.comm₂,
  have eq₁₃' := iso₁₃.hom.comm₃,
  have eq₂₃ := iso₂₃.hom.comm₂,
  have eq₂₃' := iso₂₃.hom.comm₃,
  have rel₁₂ := H.triangle_morphism₁.comm₂,
  have rel₁₃ := H.triangle_morphism₁.comm₃,
  have rel₂₂ := H.triangle_morphism₂.comm₂,
  have rel₂₃ := H.triangle_morphism₂.comm₃,
  dsimp at eq₁₂ eq₁₂' eq₁₃ eq₁₃' eq₂₃ eq₂₃' rel₁₂ rel₁₃ rel₂₂ rel₂₃,
  rw [functor.map_id, comp_id] at rel₁₃,
  rw id_comp at rel₂₂,
  refine ⟨iso₁₂.hom.hom₃ ≫ H.m₁ ≫ iso₁₃.inv.hom₃,
    iso₁₃.hom.hom₃ ≫ H.m₃ ≫ iso₂₃.inv.hom₃, _, _, _, _, _⟩,
  { simp only [reassoc_of eq₁₂, ← cancel_mono iso₁₃.hom.hom₃, assoc,
      iso₁₃.triangle_inv_hom_id₃, eq₁₃, reassoc_of comm₂₃, ← rel₁₂],
    dsimp,
    rw comp_id, },
  { rw [← cancel_mono ((shift_functor C (1 : ℤ)).map e₁.hom), eq₁₂', assoc, assoc, assoc, eq₁₃',
      iso₁₃.triangle_inv_hom_id₃_assoc, ← rel₁₃], },
  { rw [reassoc_of eq₁₃, reassoc_of rel₂₂, ← cancel_mono iso₂₃.hom.hom₃, assoc, assoc,
      iso₂₃.triangle_inv_hom_id₃, eq₂₃],
    dsimp,
    rw comp_id, },
  { rw [← cancel_mono ((shift_functor C (1 : ℤ)).map e₂.hom), assoc, assoc, assoc, assoc, eq₂₃',
      iso₂₃.triangle_inv_hom_id₃_assoc, ← rel₂₃, ← functor.map_comp, comm₁₂, functor.map_comp,
      reassoc_of eq₁₃'], },
  { refine pretriangulated.isomorphic_distinguished _ H.mem _ _,
    refine triangle.mk_iso _ _ iso₁₂.triangle_eval₃ iso₁₃.triangle_eval₃ iso₂₃.triangle_eval₃
      _ _ _ ,
    { dsimp, erw [assoc, assoc, iso.triangle_inv_hom_id₃, comp_id], },
    { dsimp, erw [assoc, assoc, iso.triangle_inv_hom_id₃, comp_id], },
    { dsimp, erw [assoc, ← functor.map_comp, eq₁₂, functor.map_comp, reassoc_of eq₂₃'], }, },
end

end triangulated

open pretriangulated triangulated

lemma is_triangulated.mk' (h : ∀ ⦃X₁' X₂' X₃' : C⦄ (u₁₂' : X₁' ⟶ X₂') (u₂₃' : X₂' ⟶ X₃'),
  ∃ (X₁ X₂ X₃ Z₁₂ Z₂₃ Z₁₃ : C) (u₁₂ : X₁ ⟶ X₂) (u₂₃ : X₂ ⟶ X₃) (e₁ : X₁' ≅ X₁) (e₂ : X₂' ≅ X₂)
    (e₃ : X₃' ≅ X₃) (comm₁₂ : u₁₂' ≫ e₂.hom = e₁.hom ≫ u₁₂)
    (comm₂₃ : u₂₃' ≫ e₃.hom = e₂.hom ≫ u₂₃)
    (v₁₂ : X₂ ⟶ Z₁₂) (w₁₂ : Z₁₂ ⟶ X₁⟦1⟧) (h₁₂ : triangle.mk u₁₂ v₁₂ w₁₂ ∈ dist_triang C)
    (v₂₃ : X₃ ⟶ Z₂₃) (w₂₃ : Z₂₃ ⟶ X₂⟦1⟧) (h₂₃ : triangle.mk u₂₃ v₂₃ w₂₃ ∈ dist_triang C)
    (v₁₃ : X₃ ⟶ Z₁₃) (w₁₃ : Z₁₃ ⟶ X₁⟦1⟧)
      (h₁₃ : triangle.mk (u₁₂ ≫ u₂₃) v₁₃ w₁₃ ∈ dist_triang C),
        nonempty (octahedron rfl h₁₂ h₂₃ h₁₃)) : is_triangulated C :=
⟨λ X₁' X₂' X₃' Z₁₂' Z₂₃' Z₁₃' u₁₂' u₂₃' u₁₃' comm' v₁₂' w₁₂' h₁₂' v₂₃' w₂₃' h₂₃'
  v₁₃' w₁₃' h₁₃', begin
  obtain ⟨X₁, X₂, X₃, Z₁₂, Z₂₃, Z₁₃, u₁₂, u₂₃, e₁, e₂, e₃, comm₁₂, comm₂₃,
    v₁₂, w₁₂, h₁₂, v₂₃, w₂₃, h₂₃, v₁₃, w₁₃, h₁₃, H⟩ := h u₁₂' u₂₃',
  exact ⟨octahedron.of_iso _ _ _ _ _ _ _ u₁₂ u₂₃ e₁ e₂ e₃ comm₁₂ comm₂₃ v₁₂ w₁₂ h₁₂
    v₂₃ w₂₃ h₂₃ v₁₃ w₁₃ h₁₃ H.some⟩
end⟩

end category_theory


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

import tactic.norm_num
import tactic.linarith
import tactic.omega
import control.lawful_fix
import order.category.omega_complete_partial_order
import data.nat.basic

universes u_1 u_2

namespace part.examples
open function has_fix omega_complete_partial_order

/-! `easy` is a trivial, non-recursive example -/

def easy.intl (easy : ℕ → ℕ → part ℕ) : ℕ → ℕ → part ℕ
| x y := pure x

def easy :=
fix easy.intl

-- automation coming soon
theorem easy.cont : continuous' easy.intl :=
pi.omega_complete_partial_order.flip₂_continuous' easy.intl
  (λ x, pi.omega_complete_partial_order.flip₂_continuous' _ (λ x_1, const_continuous' (pure x)))

-- automation coming soon
theorem easy.equations.eqn_1 (x y : ℕ) : easy x y = pure x :=
by rw [easy, lawful_fix.fix_eq' easy.cont]; refl

/-! division on natural numbers -/

def div.intl (div : ℕ → ℕ → part ℕ) : ℕ → ℕ → part ℕ
| x y :=
if y ≤ x ∧ y > 0
  then div (x - y) y
  else pure x

def div : ℕ → ℕ → part ℕ :=
fix div.intl

-- automation coming soon
theorem div.cont : continuous' div.intl :=
pi.omega_complete_partial_order.flip₂_continuous' div.intl
  (λ (x : ℕ),
     pi.omega_complete_partial_order.flip₂_continuous' (λ (g : ℕ → ℕ → part ℕ), div.intl g x)
       (λ (x_1 : ℕ),
            (continuous_hom.ite_continuous' (λ (x_2 : ℕ → ℕ → part ℕ), x_2 (x - x_1) x_1)
               (λ (x_1 : ℕ → ℕ → part ℕ), pure x)
               (pi.omega_complete_partial_order.flip₁_continuous'
                 (λ (v_1 : ℕ) (x_2 : ℕ → ℕ → part ℕ), x_2 (x - x_1) v_1) _ $
                 pi.omega_complete_partial_order.flip₁_continuous'
                   (λ (v : ℕ) (g : ℕ → ℕ → part ℕ) (x : ℕ), g v x) _ id_continuous')
               (const_continuous' (pure x)))))

-- automation coming soon
theorem div.equations.eqn_1 (x y : ℕ) : div x y = if y ≤ x ∧ y > 0 then div (x - y) y else pure x :=
by conv_lhs { rw [div, lawful_fix.fix_eq' div.cont] }; refl

inductive tree (α : Type*)
| nil {} : tree
| node (x : α) : tree → tree → tree

open part.examples.tree

/-! `map` on a `tree` using monadic notation -/
def tree_map.intl {α β : Type*} (f : α → β) (tree_map : tree α → part (tree β)) :
  tree α → part (tree β)
| nil := pure nil
| (node x t₀ t₁) :=
do tt₀ ← tree_map t₀,
   tt₁ ← tree_map t₁,
   pure $ node (f x) tt₀ tt₁

-- automation coming soon
def tree_map {α : Type u_1} {β : Type u_2} (f : α → β) : tree α → part (tree β) :=
fix (tree_map.intl f)

-- automation coming soon
theorem tree_map.cont :
  ∀ {α : Type u_1} {β : Type u_2} (f : α → β), continuous' (tree_map.intl f) :=
λ {α : Type u_1} {β : Type u_2} (f : α → β),
  pi.omega_complete_partial_order.flip₂_continuous' (tree_map.intl f)
    (λ (x : tree α),
       tree.cases_on x (id (const_continuous' (pure nil)))
         (λ (x_x : α) (x_a x_a_1 : tree α),
              (continuous_hom.bind_continuous' (λ (x : tree α → part (tree β)), x x_a)
                 (λ (x : tree α → part (tree β)) (tt₀ : tree β),
                    x x_a_1 >>= λ (tt₁ : tree β), pure (node (f x_x) tt₀ tt₁))
                 (pi.omega_complete_partial_order.flip₁_continuous' (λ (v : tree α) (x : tree α → part (tree β)), x v) x_a id_continuous')
                 (pi.omega_complete_partial_order.flip₂_continuous'
                    (λ (x : tree α → part (tree β)) (tt₀ : tree β),
                       x x_a_1 >>= λ (tt₁ : tree β), pure (node (f x_x) tt₀ tt₁))
                    (λ (x : tree β),
                       continuous_hom.bind_continuous' (λ (x : tree α → part (tree β)), x x_a_1)
                         (λ (x_1 : tree α → part (tree β)) (tt₁ : tree β), pure (node (f x_x) x tt₁))
                         (pi.omega_complete_partial_order.flip₁_continuous' (λ (v : tree α) (x : tree α → part (tree β)), x v) x_a_1
                            id_continuous')
                         (pi.omega_complete_partial_order.flip₂_continuous'
                            (λ (x_1 : tree α → part (tree β)) (tt₁ : tree β), pure (node (f x_x) x tt₁))
                            (λ (x_1 : tree β), const_continuous' (pure (node (f x_x) x x_1)))))))))

-- automation coming soon
theorem tree_map.equations.eqn_1 {α : Type u_1} {β : Type u_2} (f : α → β) :
  tree_map f nil = pure nil :=
by rw [tree_map,lawful_fix.fix_eq' (tree_map.cont f)]; refl

-- automation coming soon
theorem tree_map.equations.eqn_2 {α : Type u_1} {β : Type u_2} (f : α → β) (x : α)
  (t₀ t₁ : tree α) :
  tree_map f (node x t₀ t₁) = tree_map f t₀ >>= λ (tt₀ : tree β), tree_map f t₁ >>=
    λ (tt₁ : tree β), pure (node (f x) tt₀ tt₁) :=
by conv_lhs { rw [tree_map,lawful_fix.fix_eq' (tree_map.cont f)] }; refl

/-! `map` on a `tree` using applicative notation -/

def tree_map'.intl {α β} (f : α → β) (tree_map : tree α → part (tree β)) :
  tree α → part (tree β)
| nil := pure nil
| (node x t₀ t₁) :=
node (f x) <$> tree_map t₀ <*> tree_map t₁

-- automation coming soon
def tree_map' {α : Type u_1} {β : Type u_2} (f : α → β) : tree α → part (tree β) :=
fix (tree_map'.intl f)

-- automation coming soon
theorem tree_map'.cont :
  ∀ {α : Type u_1} {β : Type u_2} (f : α → β), continuous' (tree_map'.intl f) :=
λ {α : Type u_1} {β : Type u_2} (f : α → β),
  pi.omega_complete_partial_order.flip₂_continuous' (tree_map'.intl f)
    (λ (x : tree α),
       tree.cases_on x (id (const_continuous' (pure nil)))
         (λ (x_x : α) (x_a x_a_1 : tree α),
              (continuous_hom.seq_continuous' (λ (x : tree α → part (tree β)), node (f x_x) <$> x x_a)
                 (λ (x : tree α → part (tree β)), x x_a_1)
                 (continuous_hom.map_continuous' (node (f x_x)) (λ (x : tree α → part (tree β)), x x_a)
                    (pi.omega_complete_partial_order.flip₁_continuous' (λ (v : tree α) (x : tree α → part (tree β)), x v) x_a id_continuous'))
                 (pi.omega_complete_partial_order.flip₁_continuous' (λ (v : tree α) (x : tree α → part (tree β)), x v) x_a_1 id_continuous'))))

-- automation coming soon
theorem tree_map'.equations.eqn_1 {α : Type u_1} {β : Type u_2} (f : α → β) :
  tree_map' f nil = pure nil :=
by rw [tree_map',lawful_fix.fix_eq' (tree_map'.cont f)]; refl

-- automation coming soon
theorem tree_map'.equations.eqn_2 {α : Type u_1} {β : Type u_2} (f : α → β) (x : α) (t₀ t₁ : tree α) :
  tree_map' f (node x t₀ t₁) = node (f x) <$> tree_map' f t₀ <*> tree_map' f t₁ :=
by conv_lhs { rw [tree_map',lawful_fix.fix_eq' (tree_map'.cont f)] }; refl

/-! f91 is a function whose proof of termination cannot rely on the structural
ordering of its arguments and does not use the usual well-founded order
on natural numbers. It is an interesting candidate to show that `fix` lets us disentangle
the issue of termination from the definition of the function. -/

def f91.intl (f91 : ℕ → part ℕ) (n : ℕ) : part ℕ :=
if n > 100
  then pure $ n - 10
  else f91 (n + 11) >>= f91

-- automation coming soon
def f91 : ℕ → part ℕ := fix f91.intl

-- automation coming soon
lemma f91.cont : continuous' f91.intl :=
pi.omega_complete_partial_order.flip₂_continuous' f91.intl
  (λ (x : ℕ),
     id
       (continuous_hom.ite_continuous' (λ (x_1 : ℕ → part ℕ), pure (x - 10)) (λ (x_1 : ℕ → part ℕ), x_1 (x + 11) >>= x_1)
          (const_continuous' (pure (x - 10)))
          (continuous_hom.bind_continuous' (λ (x_1 : ℕ → part ℕ), x_1 (x + 11)) (λ (x : ℕ → part ℕ), x)
             (pi.omega_complete_partial_order.flip₁_continuous' (λ (v : ℕ) (x : ℕ → part ℕ), x v) (x + 11) id_continuous')
             (pi.omega_complete_partial_order.flip₂_continuous' (λ (x : ℕ → part ℕ), x)
                (λ (x_1 : ℕ), pi.omega_complete_partial_order.flip₁_continuous' (λ (v : ℕ) (g : ℕ → part ℕ), g v) x_1 id_continuous')))))
.
-- automation coming soon
theorem f91.equations.eqn_1 (n : ℕ) : f91 n = ite (n > 100) (pure (n - 10)) (f91 (n + 11) >>= f91) :=
by conv_lhs { rw [f91, lawful_fix.fix_eq' f91.cont] }; refl

lemma f91_spec (n : ℕ) : (∃ n', n < n' + 11 ∧ n' ∈ f91 n) :=
begin
  apply well_founded.induction (measure_wf $ λ n, 101 - n) n,
  clear n, dsimp [measure,inv_image], intros n ih,
  by_cases h' : n > 100,
  { rw [part.examples.f91.equations.eqn_1,if_pos h'],
    existsi n - 10, rw tsub_add_eq_add_tsub, norm_num [pure],
    apply le_of_lt, transitivity 100, norm_num, exact h' },
  { rw [part.examples.f91.equations.eqn_1,if_neg h'],
    simp, rcases ih (n + 11) _ with ⟨n',hn₀,hn₁⟩,
    rcases ih (n') _ with ⟨n'',hn'₀,hn'₁⟩,
    refine ⟨n'',_,_,hn₁,hn'₁⟩,
    { clear ih hn₁ hn'₁, omega },
    { clear ih hn₁, omega },
    { clear ih, omega } },
end

lemma f91_dom (n : ℕ) : (f91 n).dom :=
by rw part.dom_iff_mem; apply exists_imp_exists _ (f91_spec n); simp

def f91' (n : ℕ) : ℕ := (f91 n).get (f91_dom n)

run_cmd guard (f91' 109 = 99)

lemma f91_spec' (n : ℕ) : f91' n = if n > 100 then n - 10 else 91 :=
begin
  suffices : (∃ n', n' ∈ f91 n ∧ n' = if n > 100 then n - 10 else 91),
  { dsimp [f91'], rw part.get_eq_of_mem,
    rcases this with ⟨n,_,_⟩, subst n, assumption },
  apply well_founded.induction (measure_wf $ λ n, 101 - n) n,
  clear n, dsimp [measure,inv_image], intros n ih,
  by_cases h' : n > 100,
  { rw [part.examples.f91.equations.eqn_1,if_pos h',if_pos h'],
    simp [pure] },
  { rw [part.examples.f91.equations.eqn_1,if_neg h',if_neg h'],
    simp, rcases ih (n + 11) _ with ⟨n',hn'₀,hn'₁⟩,
    split_ifs at hn'₁,
    { subst hn'₁, norm_num at hn'₀, refine ⟨_,hn'₀,_⟩,
      rcases ih (n+1) _ with ⟨n',hn'₀,hn'₁⟩,
      split_ifs at hn'₁,
      { subst n', convert hn'₀, clear hn'₀ hn'₀ ih, omega },
      { subst n', exact hn'₀ },
      { clear ih hn'₀, omega } },
    { refine ⟨_,hn'₀,_⟩, subst n',
      rcases ih 91 _ with ⟨n',hn'₀,hn'₁⟩,
      rw if_neg at hn'₁, subst n', exact hn'₀,
      { clear ih hn'₀ hn'₀, omega, },
      { clear ih hn'₀, omega, } },
    { clear ih, omega } }
end

end part.examples


import for_mathlib.algebra.homology.k_projective
import category_theory.abelian.injective

noncomputable theory

open category_theory category_theory.category category_theory.limits

namespace category_theory

namespace short_complex

variables {C : Type*} [category C] [has_zero_morphisms C]
  (S : short_complex C) [has_homology S]

def homology_op_iso : S.op.homology ≅ opposite.op S.homology :=
begin
  let h := S.some_homology_data,
  exact h.op.homology_iso ≪≫ h.iso.op ≪≫ h.homology_iso.op,
end

end short_complex

end category_theory

open category_theory

namespace cochain_complex

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

namespace op_equivalence

@[simps]
def op_obj (K : cochain_complex C ℤ) :
  cochain_complex Cᵒᵖ ℤ :=
{ X := λ n, opposite.op (K.X (-n)),
  d := λ n m, (K.d _ _).op,
  shape' := λ i j hij, begin
    rw K.shape,
    { refl, },
    { simp only [complex_shape.up_rel] at ⊢ hij,
      intro h,
      apply hij,
      linarith, },
  end,
  d_comp_d' := λ i j k hij hjk,
    by simpa only [← op_comp, homological_complex.d_comp_d], }

@[simps]
def unop_obj (K : cochain_complex Cᵒᵖ ℤ) :
  cochain_complex C ℤ :=
{ X := λ n, opposite.unop (K.X (-n)),
  d := λ n m, (K.d _ _).unop,
  shape' := λ i j hij, begin
    rw K.shape,
    { refl, },
    { simp only [complex_shape.up_rel] at ⊢ hij,
      intro h,
      apply hij,
      linarith, },
  end,
  d_comp_d' := λ i j k hij hjk,
    by simpa only [← unop_comp, homological_complex.d_comp_d], }

@[simps]
def unop_op_obj (K : cochain_complex C ℤ) :
  unop_obj (op_obj K) ≅ K :=
homological_complex.hom.iso_of_components
  (λ n, homological_complex.X_iso_of_eq K (by linarith)) (by tidy)

@[simps]
def op_unop_obj (K : cochain_complex Cᵒᵖ ℤ) :
  op_obj (unop_obj K) ≅ K :=
homological_complex.hom.iso_of_components
  (λ n, homological_complex.X_iso_of_eq K (by linarith)) (by tidy)

variable (C)

@[simps]
def functor : (cochain_complex C ℤ)ᵒᵖ ⥤ cochain_complex Cᵒᵖ ℤ :=
{ obj := λ K, op_obj (opposite.unop K) ,
  map := λ K L φ,
  { f := λ n, (φ.unop.f (-n)).op,
    comm' := λ i j hij, begin
      dsimp,
      simp only [← op_comp, homological_complex.hom.comm],
    end, }, }

@[simps]
def inverse : cochain_complex Cᵒᵖ ℤ ⥤ (cochain_complex C ℤ)ᵒᵖ :=
{ obj := λ K, opposite.op (unop_obj K),
  map := λ K L φ, quiver.hom.op
  { f := λ n, (φ.f (-n)).unop,
    comm' := λ i j hij, begin
      dsimp,
      simp only [← unop_comp, homological_complex.hom.comm],
    end, }, }

@[simps]
def unit_iso :
  𝟭 (cochain_complex C ℤ)ᵒᵖ ≅ op_equivalence.functor C ⋙ op_equivalence.inverse C :=
nat_iso.of_components (λ K, (unop_op_obj (opposite.unop K)).op)
  (λ K L f, quiver.hom.unop_inj begin
    ext n,
    dsimp,
    symmetry,
    apply homological_complex.X_iso_of_eq_hom_naturality f.unop,
  end)

@[simps]
def counit_iso :
  op_equivalence.inverse C ⋙ op_equivalence.functor C ≅ 𝟭 (cochain_complex Cᵒᵖ ℤ) :=
nat_iso.of_components (λ K, (op_unop_obj K))
  (λ K L f, begin
    ext n,
    dsimp,
    apply homological_complex.X_iso_of_eq_hom_naturality f,
  end)

end op_equivalence

variable (C)

@[simps]
def op_equivalence : (cochain_complex C ℤ)ᵒᵖ ≌ cochain_complex Cᵒᵖ ℤ :=
{ functor := op_equivalence.functor C,
  inverse := op_equivalence.inverse C,
  unit_iso := op_equivalence.unit_iso C,
  counit_iso := op_equivalence.counit_iso C,
  functor_unit_iso_comp' := λ K, begin
    ext n,
    dsimp [homological_complex.X_iso_of_eq],
    simp only [eq_to_hom_op, eq_to_hom_trans, eq_to_hom_refl],
  end, }

variable {C}

lemma op_obj_is_strictly_le (K : cochain_complex C ℤ) (n : ℤ) [K.is_strictly_ge (-n)] :
  (op_equivalence.op_obj K).is_strictly_le n :=
⟨λ i hi, (cochain_complex.is_strictly_ge.is_zero K (-n) (-i) (by linarith)).op⟩

lemma op_obj_is_strictly_ge (K : cochain_complex C ℤ) (n : ℤ) [K.is_strictly_le (-n)] :
  (op_equivalence.op_obj K).is_strictly_ge n :=
⟨λ i hi, (cochain_complex.is_strictly_le.is_zero K (-n) (-i) (by linarith)).op⟩

lemma unop_obj_is_strictly_le (K : cochain_complex Cᵒᵖ ℤ) (n : ℤ) [K.is_strictly_ge (-n)] :
  (op_equivalence.unop_obj K).is_strictly_le n :=
⟨λ i hi, (cochain_complex.is_strictly_ge.is_zero K (-n) (-i) (by linarith)).unop⟩

lemma unop_obj_is_strictly_ge (K : cochain_complex Cᵒᵖ ℤ) (n : ℤ) [K.is_strictly_le (-n)] :
  (op_equivalence.unop_obj K).is_strictly_ge n :=
⟨λ i hi, (cochain_complex.is_strictly_le.is_zero K (-n) (-i) (by linarith)).unop⟩

def unop_homotopy {K L : cochain_complex C ℤ} {f₁ f₂ : K ⟶ L}
  (h : homotopy ((op_equivalence.functor C).map f₁.op) ((op_equivalence.functor C).map f₂.op)) :
  homotopy f₁ f₂ :=
{ hom := λ i j, (K.X_iso_of_eq (by simp)).hom ≫ (h.hom (-j) (-i)).unop ≫
      (L.X_iso_of_eq (by simp)).hom,
  zero' := λ i j hij, begin
    rw [h.zero, unop_zero, zero_comp, comp_zero],
    simp only [complex_shape.up_rel] at hij ⊢,
    intro h,
    apply hij,
    linarith,
  end,
  comm := λ n, quiver.hom.op_inj begin
    obtain ⟨m, rfl⟩ : ∃ (m : ℤ), n = -m := ⟨-n, by rw neg_neg n⟩,
    have eq := h.comm m,
    have eq₁ : (complex_shape.up ℤ).rel m (m+1) := rfl,
    have eq₂ : (complex_shape.up ℤ).rel (m-1) m := by simp,
    have eq₃ : (complex_shape.up ℤ).rel (-m) (-(m-1)),
    { simp only [neg_sub, complex_shape.up_rel], linarith, },
    have eq₄ : (complex_shape.up ℤ).rel (-(m+1)) (-m) := by simp,
    rw [d_next_eq _ eq₁, prev_d_eq _ eq₂] at eq,
    rw [d_next_eq _ eq₃, prev_d_eq _ eq₄],
    dsimp at eq ⊢,
    rw eq,
    have eq₅ : ∀ (a a' b b' : ℤ) (ha : a = a') (hb : b = b'),
      h.hom a b = eq_to_hom (by rw ha) ≫ h.hom a' b' ≫ eq_to_hom (by rw hb),
    { intros a a' b b' ha hb,
      substs ha hb,
      simp only [eq_to_hom_refl, id_comp, comp_id], },
    conv_lhs { congr, rw add_comm, },
    congr' 3;
    { dsimp [homological_complex.X_iso_of_eq],
      simp only [assoc, eq_to_hom_op],
      exact eq₅ _ _ _ _ (neg_neg _).symm (neg_neg _).symm, },
  end, }

def homology_op_iso (K : cochain_complex C ℤ) (n : ℤ) :
  (op_equivalence.op_obj K).homology n ≅ opposite.op (K.homology (-n)) :=
begin
  have r₁ : (complex_shape.up ℤ).rel (-(n+1)) (-n) := by simp,
  have r₂ : (complex_shape.up ℤ).rel (-n) (-(n-1)) := by { rw complex_shape.up_rel, linarith, },
  have r₃ : (complex_shape.up ℤ).rel (n-1) n := by simp,
  have r₄ : (complex_shape.up ℤ).rel n (n+1) := by simp,
  refine _ ≪≫ short_complex.homology_op_iso _ ≪≫
    (short_complex.homology_map_iso
      ((homological_complex.short_complex_functor_nat_iso C _ r₁ r₂).app K)).op,
  exact short_complex.homology_map_iso
    ((homological_complex.short_complex_functor_nat_iso Cᵒᵖ _ r₃ r₄).app ((op_equivalence.op_obj K))),
end

lemma acyclic_op {K : cochain_complex C ℤ} (hK : homological_complex.acyclic K) :
  homological_complex.acyclic (op_equivalence.op_obj K) :=
λ n, is_zero.of_iso (hK (-n)).op (homology_op_iso K n)

end cochain_complex


import o_minimal.sheaf.yoneda

namespace o_minimal

variables {R : Type*} (S : struc R)

class is_good_uncurry' (α β γ : Type*) [function.has_uncurry α β γ]
  [definable_sheaf S α] [definable_sheaf S β] [definable_sheaf S γ] :=
(definable_iff : ∀ (K : Def S) (f : K → α),
   definable S f ↔ definable S (λ k, ↿(f k)))

instance base.is_good_uncurry' {α β : Type*}
  [definable_sheaf S α] [definable_sheaf S β] : is_good_uncurry' S (α → β) α β :=
⟨λ K f, iff.rfl⟩

instance induction.is_good_uncurry' {α β γ δ : Type*} [function.has_uncurry β γ δ]
  [definable_sheaf S α] [definable_sheaf S β] [definable_sheaf S γ] [definable_sheaf S δ] :
  is_good_uncurry' S (α → β) (α × γ) δ :=
begin
  refine ⟨λ K f, _⟩,
  change _ ↔ definable S (λ k, function.uncurry (λ a c, ↿(f k a) c)),
  split; intro H,
  { begin [defin]
      intro k,
      app, exact definable.uncurry.definable _,
      intro a,
      intro c,
      app,
      exact sorry,
      var,
    end
},
  { let g := λ k, function.uncurry (λ a c, ↿(f k a) c),
    change definable S g at H,
    sorry }
end

class is_good_uncurry (α β γ : Type*) [function.has_uncurry α β γ]
  [definable_sheaf S α]
  [has_coordinates R β] [is_definable S β]
  [has_coordinates R γ] [is_definable S γ] :=
(x : @is_good_uncurry' R S α β γ _ _ definable_sheaf.rep definable_sheaf.rep)

variables {S}

lemma definable_iff_uncurry' {α β γ : Type*} [function.has_uncurry α β γ]
  [definable_sheaf S α]
  [has_coordinates R β] [is_definable S β]
  [has_coordinates R γ] [is_definable S γ]
  [i : is_good_uncurry S α β γ]
  {f : α} :
  definable S f ↔ def_fun S ↿f :=
begin
  letI : definable_sheaf S β := definable_sheaf.rep,
  letI : definable_sheaf S γ := definable_sheaf.rep,
  letI : definable_rep S β := ⟨λ _ _, iff.rfl⟩,
  letI : definable_rep S γ := ⟨λ _ _, iff.rfl⟩,
  letI := i.x,
  sorry -- exact (is_good_uncurry'.definable_iff f).trans definable_iff_def_fun
end

end o_minimal


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.isomorphism
import category_theory.functor.category
import category_theory.functor.fully_faithful

/-!
# Whiskering

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

Given a functor `F  : C ⥤ D` and functors `G H : D ⥤ E` and a natural transformation `α : G ⟶ H`,
we can construct a new natural transformation `F ⋙ G ⟶ F ⋙ H`,
called `whisker_left F α`. This is the same as the horizontal composition of `𝟙 F` with `α`.

This operation is functorial in `F`, and we package this as `whiskering_left`. Here
`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
(That is, we might have alternatively named this as the "left composition functor".)

We also provide analogues for composition on the right, and for these operations on isomorphisms.

At the end of the file, we provide the left and right unitors, and the associator,
for functor composition.
(In fact functor composition is definitionally associative, but very often relying on this causes
extremely slow elaboration, so it is better to insert it explicitly.)
We also show these natural isomorphisms satisfy the triangle and pentagon identities.
-/

namespace category_theory

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

section
variables {C : Type u₁} [category.{v₁} C]
          {D : Type u₂} [category.{v₂} D]
          {E : Type u₃} [category.{v₃} E]

/--
If `α : G ⟶ H` then
`whisker_left F α : (F ⋙ G) ⟶ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
@[simps] def whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) : (F ⋙ G) ⟶ (F ⋙ H) :=
{ app := λ X, α.app (F.obj X),
  naturality' := λ X Y f, by rw [functor.comp_map, functor.comp_map, α.naturality] }

/--
If `α : G ⟶ H` then
`whisker_right α F : (G ⋙ F) ⟶ (G ⋙ F)` has components `F.map (α.app X)`.
-/
@[simps] def whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) : (G ⋙ F) ⟶ (H ⋙ F) :=
{ app := λ X, F.map (α.app X),
  naturality' := λ X Y f,
    by rw [functor.comp_map, functor.comp_map, ←F.map_comp, ←F.map_comp, α.naturality] }

variables (C D E)

/--
Left-composition gives a functor `(C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E))`.

`(whiskering_left.obj F).obj G` is `F ⋙ G`, and
`(whiskering_left.obj F).map α` is `whisker_left F α`.
-/
@[simps] def whiskering_left : (C ⥤ D) ⥤ ((D ⥤ E) ⥤ (C ⥤ E)) :=
{ obj := λ F,
  { obj := λ G, F ⋙ G,
    map := λ G H α, whisker_left F α },
  map := λ F G τ,
  { app := λ H,
    { app := λ c, H.map (τ.app c),
      naturality' := λ X Y f, begin dsimp, rw [←H.map_comp, ←H.map_comp, ←τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [f.naturality] end } }

/--
Right-composition gives a functor `(D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E))`.

`(whiskering_right.obj H).obj F` is `F ⋙ H`, and
`(whiskering_right.obj H).map α` is `whisker_right α H`.
-/
@[simps] def whiskering_right : (D ⥤ E) ⥤ ((C ⥤ D) ⥤ (C ⥤ E)) :=
{ obj := λ H,
  { obj := λ F, F ⋙ H,
    map := λ _ _ α, whisker_right α H },
  map := λ G H τ,
  { app := λ F,
    { app := λ c, τ.app (F.obj c),
      naturality' := λ X Y f, begin dsimp, rw [τ.naturality] end },
    naturality' := λ X Y f, begin ext, dsimp, rw [←nat_trans.naturality] end } }

variables {C} {D} {E}

instance faithful_whiskering_right_obj {F : D ⥤ E} [faithful F] :
  faithful ((whiskering_right C D E).obj F) :=
{ map_injective' := λ G H α β hαβ, nat_trans.ext _ _ $ funext $ λ X,
    functor.map_injective _ $ congr_fun (congr_arg nat_trans.app hαβ) X }

@[simp] lemma whisker_left_id (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (nat_trans.id G) = nat_trans.id (F.comp G) :=
rfl
@[simp] lemma whisker_left_id' (F : C ⥤ D) {G : D ⥤ E} :
  whisker_left F (𝟙 G) = 𝟙 (F.comp G) :=
rfl

@[simp] lemma whisker_right_id {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (nat_trans.id G) F = nat_trans.id (G.comp F) :=
((whiskering_right C D E).obj F).map_id _
@[simp] lemma whisker_right_id' {G : C ⥤ D} (F : D ⥤ E) :
  whisker_right (𝟙 G) F = 𝟙 (G.comp F) :=
((whiskering_right C D E).obj F).map_id _

@[simp] lemma whisker_left_comp (F : C ⥤ D) {G H K : D ⥤ E} (α : G ⟶ H) (β : H ⟶ K) :
  whisker_left F (α ≫ β) = (whisker_left F α) ≫ (whisker_left F β) :=
rfl

@[simp] lemma whisker_right_comp {G H K : C ⥤ D} (α : G ⟶ H) (β : H ⟶ K) (F : D ⥤ E)  :
  whisker_right (α ≫ β) F = (whisker_right α F) ≫ (whisker_right β F) :=
((whiskering_right C D E).obj F).map_comp α β

/--
If `α : G ≅ H` is a natural isomorphism then
`iso_whisker_left F α : (F ⋙ G) ≅ (F ⋙ H)` has components `α.app (F.obj X)`.
-/
def iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) : (F ⋙ G) ≅ (F ⋙ H) :=
((whiskering_left C D E).obj F).map_iso α
@[simp] lemma iso_whisker_left_hom (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).hom = whisker_left F α.hom :=
rfl
@[simp] lemma iso_whisker_left_inv (F : C ⥤ D) {G H : D ⥤ E} (α : G ≅ H) :
  (iso_whisker_left F α).inv = whisker_left F α.inv :=
rfl

/--
If `α : G ≅ H` then
`iso_whisker_right α F : (G ⋙ F) ≅ (H ⋙ F)` has components `F.map_iso (α.app X)`.
-/
def iso_whisker_right {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) : (G ⋙ F) ≅ (H ⋙ F) :=
((whiskering_right C D E).obj F).map_iso α
@[simp] lemma iso_whisker_right_hom {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).hom = whisker_right α.hom F :=
rfl
@[simp] lemma iso_whisker_right_inv {G H : C ⥤ D} (α : G ≅ H) (F : D ⥤ E) :
  (iso_whisker_right α F).inv = whisker_right α.inv F :=
rfl

instance is_iso_whisker_left (F : C ⥤ D) {G H : D ⥤ E} (α : G ⟶ H) [is_iso α] :
  is_iso (whisker_left F α) :=
is_iso.of_iso (iso_whisker_left F (as_iso α))
instance is_iso_whisker_right {G H : C ⥤ D} (α : G ⟶ H) (F : D ⥤ E) [is_iso α] :
  is_iso (whisker_right α F) :=
is_iso.of_iso (iso_whisker_right (as_iso α) F)

variables {B : Type u₄} [category.{v₄} B]

local attribute [elab_simple] whisker_left whisker_right

@[simp] lemma whisker_left_twice (F : B ⥤ C) (G : C ⥤ D) {H K : D ⥤ E} (α : H ⟶ K) :
  whisker_left F (whisker_left G α) = whisker_left (F ⋙ G) α :=
rfl

@[simp] lemma whisker_right_twice {H K : B ⥤ C} (F : C ⥤ D) (G : D ⥤ E) (α : H ⟶ K) :
  whisker_right (whisker_right α F) G = whisker_right α (F ⋙ G) :=
rfl

lemma whisker_right_left (F : B ⥤ C) {G H : C ⥤ D} (α : G ⟶ H) (K : D ⥤ E) :
  whisker_right (whisker_left F α) K = whisker_left F (whisker_right α K) :=
rfl
end

namespace functor

universes u₅ v₅

variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]

/--
The left unitor, a natural isomorphism `((𝟭 _) ⋙ F) ≅ F`.
-/
@[simps] def left_unitor (F : A ⥤ B) : ((𝟭 A) ⋙ F) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

/--
The right unitor, a natural isomorphism `(F ⋙ (𝟭 B)) ≅ F`.
-/
@[simps] def right_unitor (F : A ⥤ B) : (F ⋙ (𝟭 B)) ≅ F :=
{ hom := { app := λ X, 𝟙 (F.obj X) },
  inv := { app := λ X, 𝟙 (F.obj X) } }

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

/--
The associator for functors, a natural isomorphism `((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H))`.

(In fact, `iso.refl _` will work here, but it tends to make Lean slow later,
and it's usually best to insert explicit associators.)
-/
@[simps] def associator (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) ≅ (F ⋙ (G ⋙ H)) :=
{ hom := { app := λ _, 𝟙 _ },
  inv := { app := λ _, 𝟙 _ } }

@[protected]
lemma assoc (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) : ((F ⋙ G) ⋙ H) = (F ⋙ (G ⋙ H)) := rfl

lemma triangle (F : A ⥤ B) (G : B ⥤ C) :
  (associator F (𝟭 B) G).hom ≫ (whisker_left F (left_unitor G).hom) =
    (whisker_right (right_unitor F).hom G) :=
by { ext, dsimp, simp }  -- See note [dsimp, simp].

variables {E : Type u₅} [category.{v₅} E]

variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D) (K : D ⥤ E)

lemma pentagon :
  (whisker_right (associator F G H).hom K) ≫
    (associator F (G ⋙ H) K).hom ≫
    (whisker_left F (associator G H K).hom) =
  ((associator (F ⋙ G) H K).hom ≫ (associator F G (H ⋙ K)).hom) :=
by { ext, dsimp, simp }

end functor

end category_theory


import pseudo_normed_group.category.strictProFiltPseuNormGrpWithTinv
import laurent_measures.functor
import condensed.ab
import condensed.rescale
import condensed.exact
import for_mathlib.split_exact
.

noncomputable theory

universe u

open_locale nnreal
open category_theory

variables {C D : Type*} [category C] [category D] (r' : ℝ≥0) [fact (0 < r')]

abbreviation category_theory.nat_trans.conj_by {F G : C ⥤ D} (α : F ≅ G) (β : G ⟶ G) :
  F ⟶ F := α.hom ≫ β ≫ α.inv

open category_theory

open ProFiltPseuNormGrpWithTinv₁ CompHausFiltPseuNormGrp₁ CompHausFiltPseuNormGrp

variables {r'}

/--
Given a functor `F` from `Fintype` to `CompHausFiltPseuNormGrp₁`, we can obtain
a functor `Profinite ⥤ CompHausFiltPseuNormGrp₁` by expressing any profinite
set as a limit of finite sets and taking a limit in the target category.
We then compose with the functor to condensed abelian groups, and the result is
called `condensify F`.
-/
def condensify (F : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  Profinite.{u} ⥤ Condensed.{u} Ab.{u+1} :=
(Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) ⋙ to_Condensed.{u}

variables {F G H : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
variables (α β : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u})
variables (c cα cβ cαβ : ℝ≥0) [fact (0 < c)]  [fact (0 < cα)] [fact (0 < cβ)] [fact (0 < cαβ)]

/--
Given functors `F G : Fintype ⥤ CompHausFiltPseuNormGrp₁` and a
natural transformation `η` between the induced functors `Fintype ⥤ CompHausFiltPseuNormGrp`
(obtained by composing with `CHFPNG₁_to_CHFPNGₑₗ`), such that the components of `η` are bounded
by a *single* `c : ℝ≥0`, this is the morphism between the associated condensed abelian groups.
-/
def condensify_nonstrict
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  condensify F ⟶ condensify G :=
whisker_right (nonstrict_extend.{u} α c h) to_Condensed

lemma condensify_nonstrict_id (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (nat_trans.app (𝟙 (F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u})) X).bound_by c) :
  condensify_nonstrict (𝟙 _) c h = 𝟙 _ :=
by { simp only [condensify_nonstrict, nonstrict_extend_id, whisker_right_id'], refl }

lemma condensify_nonstrict_comp
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (β : G ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ H ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α ≫ β).app X).bound_by cαβ) :
  condensify_nonstrict (α ≫ β) cαβ hαβ =
    condensify_nonstrict α cα hα ≫ condensify_nonstrict β cβ hβ :=
begin
  simp only [condensify_nonstrict, whisker_right_comp],
  rw [nonstrict_extend_comp cα cβ cαβ _ _ _ _, whisker_right_comp],
end

def condensify_map (α : F ⟶ G) : condensify F ⟶ condensify G :=
condensify_nonstrict (whisker_right α _) 1
  (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one)

lemma condensify_map_id (F : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  condensify_map (𝟙 F) = 𝟙 (condensify F) :=
condensify_nonstrict_id _ _

lemma condensify_map_comp (α : F ⟶ G) (β : G ⟶ H) :
  condensify_map (α ≫ β) = condensify_map α ≫ condensify_map β :=
begin
  dsimp only [condensify_map],
  simp only [whisker_right_comp],
  apply condensify_nonstrict_comp,
end

def condensify_def (F : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}) :
  condensify F ≅ Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⋙ to_Condensed.{u} :=
iso.refl _

/-- Given a family `F` of profinitely filtered normed groups with `T⁻¹`,
  indexed by a category (and such that all the morphisms in the family are strict),
  `Tinv_nat_trans` is the associated (possibly non-strict) morphism from the
  corresponding family of `CompHaus`ly filtered pseudo-normed groups coming from `T⁻¹`.
  -/
def Tinv_nat_trans (F : C ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
  (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r') ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶
  (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r') ⋙ CHFPNG₁_to_CHFPNGₑₗ :=
{ app := λ X, profinitely_filtered_pseudo_normed_group_with_Tinv.Tinv,
  naturality' := λ X Y f, by { ext x, exact ((F.map f).map_Tinv x).symm } }

/-- The endomorphism `T⁻¹ - 2` of a strict family of profinitely-filtered
pseudo-normed groups with `T⁻¹`, considered as a possibly non-strict
endomorphism of the associated `CompHaus`ly filtered pseudo-normed groups. -/
def Tinv2_nat_trans (F : C ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
  (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r') ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶
  (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r') ⋙ CHFPNG₁_to_CHFPNGₑₗ :=
Tinv_nat_trans F - 2 • 𝟙 _

lemma Tinv_bound_by (F : C ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') (X : C) :
  ((Tinv_nat_trans F).app X).bound_by r'⁻¹ :=
profinitely_filtered_pseudo_normed_group_with_Tinv.Tinv_bound_by

lemma twoid_bound_by (F : C ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') (X : C) :
  comphaus_filtered_pseudo_normed_group_hom.bound_by
    ((2 • 𝟙 ((F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') ⋙ CHFPNG₁_to_CHFPNGₑₗ)).app X) 2 :=
begin
  simp only [nat_trans.app_nsmul, nat_trans.id_app],
  refine ((comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ 1 _).nsmul 2).mono _ _,
  norm_num,
end

lemma Tinv2_bound_by (F : C ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') (X : C) :
  ((Tinv2_nat_trans F).app X).bound_by (r'⁻¹ + 2) :=
(Tinv_bound_by F X).sub (twoid_bound_by F X)

@[reassoc]
lemma Tinv_nat_trans_comp {F G : C ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r'} (α : F ⟶ G) :
  Tinv_nat_trans F ≫ @whisker_right _ _ _ _ _ _ F G α (PFPNGT₁_to_CHFPNG₁ₑₗ r' ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) =
  @whisker_right _ _ _ _ _ _ F G α (PFPNGT₁_to_CHFPNG₁ₑₗ r' ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) ≫ Tinv_nat_trans G :=
by { ext X x, exact (α.app X).map_Tinv x }

-- move me
instance fact_inv_pos : fact (0 < r'⁻¹) := ⟨nnreal.inv_pos.2 $ fact.out _⟩

--set_option pp.universes true

/--
Given a functor from `Fintype` to `ProFiltPseuNormGrpWithTinv₁`, the `T⁻¹` action
is a nonstrict morphism which is natural (see `Tinv_nat_trans`) and thus
induces a morphism on the associated condensed abelian groups.
-/
def condensify_Tinv (F : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
  condensify.{u} (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') ⟶ condensify.{u} (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') :=
condensify_nonstrict (Tinv_nat_trans _) r'⁻¹ (Tinv_bound_by _)

/--
A variant of `condensify_Tinv` with a different bound, given by `r'⁻¹ + 2`.
-/
def condensify_Tinv2 (F : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
  condensify.{u} (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') ⟶ condensify.{u} (F ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') :=
condensify_nonstrict (Tinv2_nat_trans _) (r'⁻¹ + 2) (Tinv2_bound_by _)

lemma condensify_map_comp_Tinv {F G : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r'}
  (α : F ⟶ G) :
  condensify_map (whisker_right α (PFPNGT₁_to_CHFPNG₁ₑₗ r')) ≫ condensify_Tinv G =
  condensify_Tinv F ≫ condensify_map (whisker_right α (PFPNGT₁_to_CHFPNG₁ₑₗ r')) :=
begin
  delta condensify_map condensify_Tinv,
  rw [← condensify_nonstrict_comp 1 r'⁻¹ r'⁻¹, ← condensify_nonstrict_comp r'⁻¹ 1 r'⁻¹],
  swap, {
    intro X,
    rw nat_trans.comp_app,
    rw ← one_mul r'⁻¹,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp (Tinv_bound_by F X),
    simp only [whisker_right_twice, whisker_right_app, functor.comp_map, CHFPNG₁_to_CHFPNGₑₗ_map],
    apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one
    },
  swap, {
    intro X,
    rw nat_trans.comp_app,
    rw ← mul_one r'⁻¹,
    refine comphaus_filtered_pseudo_normed_group_hom.bound_by.comp _ (Tinv_bound_by G X),
    simp only [whisker_right_twice, whisker_right_app, functor.comp_map, CHFPNG₁_to_CHFPNGₑₗ_map],
    apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one, },
  { simp only [whisker_right_twice, Tinv_nat_trans_comp], },
end
.

section

lemma condensify_nonstrict_map_add
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α + β).app X).bound_by cαβ) :
  condensify_nonstrict (α + β) cαβ hαβ =
  condensify_nonstrict α cα hα + condensify_nonstrict β cβ hβ :=
begin
  delta condensify_nonstrict,
  rw [nonstrict_extend_map_add _ _ cα cβ cαβ hα hβ],
  refl,
end

lemma condensify_nonstrict_map_neg
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((-α).app X).bound_by cβ) :
  condensify_nonstrict (-α) cβ hβ = -condensify_nonstrict α cα hα :=
begin
  delta condensify_nonstrict,
  rw [nonstrict_extend_map_neg _ _ cβ hα],
  refl,
end

lemma condensify_nonstrict_map_sub
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α - β).app X).bound_by cαβ) :
  condensify_nonstrict (α - β) cαβ hαβ =
  condensify_nonstrict α cα hα - condensify_nonstrict β cβ hβ :=
begin
  delta condensify_nonstrict,
  rw [nonstrict_extend_map_sub _ _ cα cβ cαβ hα hβ],
  refl,
end

lemma condensify_nonstrict_map_nsmul (n : ℕ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((n • α).app X).bound_by cβ) :
  condensify_nonstrict (n • α) cβ hβ = n • condensify_nonstrict α cα hα :=
begin
  delta condensify_nonstrict,
  rw [nonstrict_extend_map_nsmul _ _ cβ n hα],
  clear hβ,
  induction n with n ih,
  { rw [zero_smul, zero_smul], refl },
  { rw [succ_nsmul, succ_nsmul, ← ih], refl, }
end

-- lemma nonstrict_extend_Tinv (F : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
--   nonstrict_extend (Tinv_nat_trans F) r'⁻¹ (Tinv_bound_by _) =
--     nat_trans.conj_by (iso_whisker_right
--       (Profinite.extend_commutes F (PFPNG₁_to_CHFPNG₁ₑₗ.{u} r')).symm enlarging_functor.{u})
--         (Tinv_nat_trans (Profinite.extend F)) :=
-- begin
--   refine nonstrict_extend_ext' _ _ r'⁻¹ (nonstrict_extend_bound_by _ _ _) _ _,
--   { admit },
--   { rw [nonstrict_extend_whisker_left],
--     simp only [whisker_left_comp, ← iso_whisker_left_hom, ← iso_whisker_left_inv,
--       ← iso.inv_comp_eq, iso.eq_comp_inv, category.assoc],
--     admit }
-- end

lemma condensify_nonstrict_Tinv (F : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
  condensify_nonstrict (Tinv_nat_trans F) r'⁻¹ (Tinv_bound_by _) = condensify_Tinv F :=
rfl

lemma condensify_nonstrict_whisker_right_enlarging (α : F ⟶ G) :
  condensify_nonstrict (whisker_right α _) 1
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) =
  condensify_map α :=
rfl

end

open pseudo_normed_group (filtration)

lemma exact_of_iso_comp_exact {V : Type u} [category V] [limits.has_images V]
  [limits.has_zero_morphisms V] [limits.has_equalizers V]
  {A B C D : V} (f : A ⟶ B) {g : B ⟶ C} {h : C ⟶ D} (hf : is_iso f) (hgh : exact g h) :
  exact (f ≫ g) h :=
by rwa exact_iso_comp

lemma condensify_nonstrict_exact
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (β : G ⟶ H)
  (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c)
  (cα cβ : ℝ≥0 → ℝ≥0) (hcα : id ≤ cα) (hcβ : id ≤ cβ)
  (H1 : ∀ S, function.injective (α.app S))
  (H2a : ∀ S, (α.app S) ≫ ((whisker_right β _).app S) = 0)
  (H2b : ∀ S c', (β.app S) ⁻¹' {0} ∩ filtration (G.obj S) c' ⊆
    (α.app S) '' filtration (F.obj S) (cα c' * c⁻¹))
  (H3b : ∀ S c', filtration (H.obj S) c' ⊆ (β.app S) '' filtration (G.obj S) (cβ c'))
  (X : Profinite.{u}) :
  short_exact ((condensify_nonstrict α c h).app X) ((condensify_map β).app X) :=
begin
  apply_with short_exact.mk { instances := ff },
  { simp only [condensify_nonstrict, nonstrict_extend, whisker_right_comp],
    repeat { apply_with mono_comp { instances := ff }; try { apply_instance } },
    apply Condensed.mono_to_Condensed_map,
    apply exact_with_constant_extend_zero_left,
    intro S,
    apply_with exact_with_constant_of_mono { instances := ff },
    rw AddCommGroup.mono_iff_injective,
    exact H1 S, },
  { dsimp only [condensify_map, condensify_nonstrict],
    rw nonstrict_extend_whisker_right_enlarging,
    apply Condensed.epi_to_Condensed_map _ cβ,
    apply exact_with_constant_extend_zero_right,
    intro S,
    apply exact_with_constant_of_epi _ _ _ hcβ (H3b S), },
  { dsimp only [condensify_map, condensify_nonstrict],
    rw nonstrict_extend_whisker_right_enlarging,
    simp only [nonstrict_extend, whisker_right_comp, nat_trans.comp_app, category.assoc],
    repeat { apply exact_of_iso_comp_exact; [apply_instance, skip] },
    apply Condensed.exact_of_exact_with_constant _ _ cα,
    apply exact_with_constant.extend,
    intro S,
    refine ⟨_, _, hcα⟩,
    { ext x, specialize H2a S, apply_fun (λ φ, φ.to_fun) at H2a, exact congr_fun H2a x },
    { intros c' y hy,
      obtain ⟨x, hx, rfl⟩ := H2b S c' hy,
      refine ⟨@rescale.of c _ x, hx, rfl⟩, } }
end
.

lemma condensify_exact (α : F ⟶ G) (β : G ⟶ H)
  (cα cβ : ℝ≥0 → ℝ≥0) (hcα : id ≤ cα) (hcβ : id ≤ cβ)
  (H1 : ∀ S, function.injective (α.app S))
  (H2a : ∀ S, α.app S ≫ β.app S = 0)
  (H2b : ∀ S c, (β.app S) ⁻¹' {0} ∩ filtration (G.obj S) c ⊆
    (α.app S) '' filtration (F.obj S) (cα c))
  (H3b : ∀ S c, filtration (H.obj S) c ⊆ (β.app S) '' filtration (G.obj S) (cβ c))
  (X : Profinite.{u}) :
  short_exact ((condensify_map α).app X) ((condensify_map β).app X) :=
begin
  refine condensify_nonstrict_exact _ _ 1 _ cα cβ hcα hcβ H1 _ _ H3b _,
  { intro S, simp only [whisker_right_app, ← functor.map_comp, H2a], refl, },
  { intros S c' x H, obtain ⟨x, hx, rfl⟩ := H2b S c' H,
    refine ⟨x, pseudo_normed_group.filtration_mono _ hx, rfl⟩,
    simp only [inv_one, mul_one], },
end

-- move me
attribute [simps] Ab.ulift

lemma condensify_Tinv2_eq (F : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r') :
  condensify_Tinv2 F = condensify_Tinv F - 2 • 𝟙 _ :=
begin
  delta condensify_Tinv2 Tinv2_nat_trans,
  rw [condensify_nonstrict_map_sub _ _ r'⁻¹ 2 (r'⁻¹ + 2) (Tinv_bound_by _) (twoid_bound_by _),
    condensify_nonstrict_map_nsmul _ 1 2, condensify_nonstrict_Tinv],
  swap,
  { intro, exact comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ 1 _ },
  rw [← condensify_map_id, ← condensify_nonstrict_whisker_right_enlarging],
  refl
end

open category_theory.preadditive

lemma condensify_map_comp_Tinv2 {F G : Fintype.{u} ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r'}
  (α : F ⟶ G) :
  condensify_map (whisker_right α (PFPNGT₁_to_CHFPNG₁ₑₗ r')) ≫ condensify_Tinv2 G =
  condensify_Tinv2 F ≫ condensify_map (whisker_right α (PFPNGT₁_to_CHFPNG₁ₑₗ r')) :=
by simp only [condensify_Tinv2_eq, comp_sub, sub_comp, comp_nsmul, nsmul_comp,
    condensify_map_comp_Tinv, category.id_comp, category.comp_id]


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.constructions.logging.logging_oracle
import computational_monads.simulation_semantics.constructions.logging.query_log.lookup
import computational_monads.simulation_semantics.constructions.logging.query_log.fork

/-!
# Seeded Simulation Oracle

This file constructs a simulation oracle that allows for a set of predetermined query responses.
The oracle takes a `query_log` as an initial state, and uses the internal values
  to respond to queries, and then forwards any additional queries back to the original oracle.
Note that if any query fails to find a seed value, the entire `query_log` is discarded,
  regardless of if further values exist for oracles of different indices.

This can more generally be thought of as a form of small-step semantics for `oracle_comp`,
  evaluating the computation using the provided value, eventually reducing to a single value,
  unless it runs out of "gas", leading to only a partial evaluation.

-/

open oracle_comp oracle_spec

variables {spec spec' spec'' : oracle_spec} {α β γ : Type}

/-- Use the first element of the `seed` as the query result if inputs match.
  If the query values don't match then throw away the seed as computation has diverged.
  Using this with a log from a previous computation ensures they behave identically. -/
def seeded_oracle (spec : oracle_spec) :
  sim_oracle spec spec (query_log spec) :=
{ default_state := query_log.init spec,
  o := λ i ⟨t, seed⟩, match seed.lookup_fst i t with
    -- Once the seed is empty, just keep it empty going forward
    | none := (λ u, (u, query_log.init spec)) <$> query i t
    | (some u) := return (u, seed.remove_head i)
    end }

namespace seeded_oracle

variables (log : query_log spec) (log' : query_log spec')

section simulate

end simulate

section eval_dist

-- Log and run, run from seed, return original output -> looks like just logging
lemma eval_dist_seeded_oracle_fst (oa : oracle_comp spec α) (i : spec.ι)
  (choose_fork : α → query_log spec → option ℕ) :
⁅do{ ⟨a, log⟩ ← simulate (logging_oracle spec) oa (query_log.init spec),
      seed ← return (log.fork_cache i $ choose_fork a log).to_seed,
      ⟨a', log'⟩ ← simulate (seeded_oracle spec) oa seed,
      return (a, log) }⁆ =
  ⁅(simulate (logging_oracle spec) oa (query_log.init spec))⁆ :=
sorry

-- Log and run, run from seed, return new output -> looks like just logging
lemma eval_dist_seeded_oracle_snd (oa : oracle_comp spec α) (i : spec.ι)
  (choose_fork : α → query_log spec → option ℕ) :
⁅do{ ⟨a, log⟩ ← simulate (logging_oracle spec) oa (query_log.init spec),
      seed ← return (log.fork_cache i $ choose_fork a log).to_seed,
      ⟨a', log'⟩ ← simulate (seeded_oracle spec) oa (seed),
      return (a', log') }⁆ =
  ⁅(simulate (logging_oracle spec) oa (query_log.init spec))⁆ :=
sorry

-- The log values match up until the point where the log was forked
lemma seeded_oracle_log_eq_log (oa : oracle_comp spec α) (i : spec.ι)
  (choose_fork : α → query_log spec → option ℕ) :
do{ ⟨a, log⟩ ← simulate (logging_oracle spec) oa (query_log.init spec),
    seed ← return (log.fork_cache i $ choose_fork a log).to_seed,
    ⟨a', log'⟩ ← simulate (seeded_oracle spec) oa (seed),
    return (a, log, log') }.support
  ⊆ λ ⟨a, log, log'⟩, log.fork_cache i (choose_fork a log) =
      log'.fork_cache i (choose_fork a log) :=
sorry

end eval_dist

end seeded_oracle