/-
  Extension of a sheaf of rings on the basis to a sheaf of rings on the whole space.

  https://stacks.math.columbia.edu/tag/009M
  https://stacks.math.columbia.edu/tag/009N
-/

import topology.opens
import sheaves.stalk_of_rings
import sheaves.stalk_of_rings_on_standard_basis
import sheaves.presheaf_of_rings_on_basis
import sheaves.presheaf_of_rings_extension
import sheaves.sheaf_on_basis
import sheaves.sheaf_on_standard_basis
import sheaves.sheaf_of_rings

open topological_space classical

noncomputable theory

universe u

section presheaf_of_rings_extension

variables {α : Type u} [T : topological_space α]
variables {B : set (opens α)} {HB : opens.is_basis B}
variables (Bstd : opens.univ ∈ B ∧ ∀ {U V}, U ∈ B → V ∈ B → U ∩ V ∈ B)

include Bstd

theorem extension_is_sheaf_of_rings
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
: is_sheaf_of_rings (F ᵣₑₓₜ Bstd) :=
begin
  show is_sheaf (F ᵣₑₓₜ Bstd).to_presheaf,
  constructor,
  { intros U OC s t Hres,
    apply subtype.eq,
    apply funext,
    intros x,
    apply funext,
    intros HxU,
    rw OC.Hcov.symm at HxU,
    rcases HxU with ⟨Uj1, ⟨⟨⟨Uj2, OUj⟩, ⟨⟨j, HUj⟩, Heq⟩⟩, HxUj⟩⟩,
    rcases Heq, rcases Heq,
    have Hstj := congr_fun (subtype.mk_eq_mk.1 (Hres j)),
    have HxUj1 : x ∈ OC.Uis j := HUj.symm ▸ HxUj,
    have Hstjx := congr_fun (Hstj x) HxUj1,
    exact Hstjx, },
  { intros U OC s Hsec,
    existsi (global_section (F.to_presheaf_on_basis) U OC s Hsec),
    intros i,
    apply subtype.eq,
    apply funext,
    intros x,
    apply funext,
    intros HxUi,
    have HxU : x ∈ U := OC.Hcov ▸ (opens_supr_subset OC.Uis i) HxUi,
    let HyUi := λ t, ∃ (H : t ∈ set.range OC.Uis), x ∈ t,
    dunfold presheaf_of_rings_extension; dsimp,
    dunfold global_section; dsimp,
    -- Same process of dealing with subtype.rec.
    let HyUi := λ t, ∃ (H : t ∈ subtype.val '' set.range OC.Uis), x ∈ t,
    rcases (classical.indefinite_description HyUi _) with ⟨S, HS⟩; dsimp,
    let HyS := λ H : S ∈ subtype.val '' set.range OC.Uis, x ∈ S,
    rcases (classical.indefinite_description HyS HS) with ⟨HSUiR, HySUiR⟩; dsimp,
    let HOUksub := λ t : subtype is_open, t ∈ set.range (OC.Uis) ∧ t.val = S,
    rcases (classical.indefinite_description HOUksub _) with ⟨OUl, ⟨HOUl, HOUleq⟩⟩; dsimp,
    let HSUi := λ i, OC.Uis i = OUl,
    cases (classical.indefinite_description HSUi _) with l HSUil; dsimp,
    -- Now we just need to apply Hsec in the right way.
    dunfold presheaf_of_rings_extension at Hsec,
    dunfold res_to_inter_left at Hsec,
    dunfold res_to_inter_right at Hsec,
    dsimp at Hsec,
    replace Hsec := Hsec i l,
    rw subtype.ext at Hsec,
    dsimp at Hsec,
    replace Hsec := congr_fun Hsec x,
    dsimp at Hsec,
    replace Hsec := congr_fun Hsec,
    have HxOUk : x ∈ OUl.val := HOUleq.symm ▸ HySUiR,
    have HxUl : x ∈ OC.Uis l := HSUil.symm ▸ HxOUk,
    exact (Hsec ⟨HxUi, HxUl⟩).symm, },
  end

section extension_coincides

-- The extension is done in a way that F(U) ≅ Fext(U).

-- The map ψ : F(U) → Π x ∈ U, Fx

def to_stalk_product (F : presheaf_on_basis α HB) {U : opens α} (BU : U ∈ B)
: F.F BU → Π (x ∈ U), stalk_on_basis F x :=
λ s x Hx, ⟦{U := U, BU := BU, Hx := Hx, s := s}⟧

lemma to_stalk_product.injective
(F : presheaf_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F)
{U : opens α} (BU : U ∈ B)
: function.injective (to_stalk_product Bstd F BU) :=
begin
  intros s₁ s₂ Hs,
  have Hsx := λ (HxU : U), congr_fun (congr_fun Hs HxU.1) HxU.2,
  let OC : covering_standard_basis B U :=
  { γ := U,
    Uis := λ HxU, some (quotient.eq.1 (Hsx HxU)),
    BUis := λ HxU, some (some_spec (quotient.eq.1 (Hsx HxU))),
    Hcov :=
      begin
        ext z,
        split,
        { rintros ⟨Ui, ⟨⟨OUi, ⟨⟨i, HUi⟩, HUival⟩⟩, HzUi⟩⟩,
          rw [←HUival, ←HUi] at HzUi,
          exact some (some_spec (some_spec (some_spec (quotient.eq.1 (Hsx i))))) HzUi, },
        { intros Hz,
          use [(some (quotient.eq.1 (Hsx ⟨z, Hz⟩))).val],
          have Hin : (some (quotient.eq.1 (Hsx ⟨z, Hz⟩))).val
            ∈ subtype.val '' set.range (λ (HxU : U), some ((quotient.eq.1 (Hsx HxU)))),
            use [classical.some ((quotient.eq.1 (Hsx ⟨z, Hz⟩)))],
            split,
            { use ⟨z, Hz⟩, },
            { refl, },
          use Hin,
          exact some (some_spec (some_spec (quotient.eq.1 (Hsx ⟨z, Hz⟩)))), },
      end, },
  apply (HF BU OC).1,
  intros i,
  replace Hs := congr_fun (congr_fun Hs i.1) i.2,
  exact some_spec (some_spec (some_spec (some_spec (some_spec (quotient.eq.1 (Hsx i)))))),
end

-- The map φ : F(U) → im(ψ).

def to_presheaf_of_rings_extension (F : presheaf_of_rings_on_basis α HB) {U : opens α} (BU : U ∈ B)
: F.F BU → (F ᵣₑₓₜ Bstd).F U :=
λ s,
  ⟨to_stalk_product Bstd F.to_presheaf_on_basis BU s,
   λ x Hx, ⟨U, BU, Hx, s, λ y Hy, funext $ λ Hy',
   quotient.sound $ ⟨U, BU, Hy', set.subset.refl U, set.subset.refl U, rfl⟩⟩⟩

lemma to_presheaf_of_rings_extension.injective
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: function.injective (to_presheaf_of_rings_extension Bstd F BU) :=
begin
  intros s₁ s₂ Hs,
  erw subtype.mk_eq_mk at Hs,
  have Hinj := to_stalk_product.injective Bstd F.to_presheaf_on_basis (λ V BV OC, HF BV OC) BU,
  exact Hinj Hs,
end

lemma to_presheaf_of_rings_extension.surjective
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: function.surjective (to_presheaf_of_rings_extension Bstd F BU) :=
begin
  intros s,
  let V := λ (HxU : U), some (s.2 HxU.1 HxU.2),
  let BV := λ (HxU : U), some (some_spec (s.2 HxU.1 HxU.2)),
  let HxV := λ (HxU : U), some (some_spec (some_spec (s.2 HxU.1 HxU.2))),
  let σ := λ (HxU : U), some (some_spec (some_spec (some_spec (s.2 HxU.1 HxU.2)))),
  let Hσ := λ (HxU : U), some_spec (some_spec (some_spec (some_spec (s.2 HxU.1 HxU.2)))),
  let OC : covering_standard_basis B U :=
  { γ := U,
    Uis := λ HxU, (V HxU) ∩ U,
    BUis := λ HxU, Bstd.2 (BV HxU) BU,
    Hcov :=
      begin
        ext z,
        split,
        { rintros ⟨Ui, ⟨⟨OUi, ⟨⟨i, HUi⟩, HUival⟩⟩, HzUi⟩⟩,
          rw [←HUival, ←HUi] at HzUi,
          exact HzUi.2, },
        { intros Hz,
          use [(some (s.2 z Hz) ∩ U).val],
          have Hin : (some (s.2 z Hz) ∩ U).val
            ∈ subtype.val '' set.range (λ (HxU : U), ((some (s.2 HxU.1 HxU.2) ∩ U : opens α))),
            use [(some (s.2 z Hz) ∩ U : opens α)],
            split,
            { use ⟨z, Hz⟩, },
            { refl, },
          use Hin,
          exact ⟨some (some_spec (some_spec (s.2 z Hz))), Hz⟩, },
      end, },
  -- Now let's try to apply sheaf condition.
  let res := λ (HxU : OC.γ), F.res (BV HxU) (Bstd.2 (BV HxU) BU) (set.inter_subset_left _ _),
  let sx := λ (HxU : OC.γ), res HxU (σ HxU),
  have Hglue := (HF BU OC).2 sx,
  have Hsx : ∀ j k,
    sheaf_on_standard_basis.res_to_inter_left Bstd F.to_presheaf_on_basis (OC.BUis j) (OC.BUis k) (sx j) =
    sheaf_on_standard_basis.res_to_inter_right Bstd F.to_presheaf_on_basis (OC.BUis j) (OC.BUis k) (sx k),
    intros j k,
    dsimp only [sheaf_on_standard_basis.res_to_inter_left],
    dsimp only [sheaf_on_standard_basis.res_to_inter_right],
    dsimp only [sx, res],
    iterate 2 { rw ←presheaf_on_basis.Hcomp', },
    show (F.to_presheaf_on_basis).res (BV j) (Bstd.2 (OC.BUis j) (OC.BUis k)) _ (σ j)
       = (F.to_presheaf_on_basis).res (BV k) (Bstd.2 (OC.BUis j) (OC.BUis k)) _ (σ k),
    -- We can cover the U ∩ Vj ∩ Vk and use locality.
    -- But first let's check that all the stalks coincide in the intersectons.
    have Hstalks : ∀ {y} (Hy : y ∈ (OC.Uis j) ∩ (OC.Uis k)),
        (⟦{U := V j, BU := BV j, Hx := Hy.1.1, s := σ j}⟧ : stalk_on_basis F.to_presheaf_on_basis y)
      = ⟦{U := V k, BU := BV k, Hx := Hy.2.1, s := σ k}⟧,
      intros y Hy,
      have Hj := congr_fun (Hσ j y ⟨Hy.1.2, Hy.1.1⟩) Hy.1.2; dsimp at Hj,
      have Hk := congr_fun (Hσ k y ⟨Hy.2.2, Hy.2.1⟩) Hy.2.2; dsimp at Hk,
      erw [←Hj, ←Hk],
    -- Therefore there exists Wjk where σj|Wjk = σk|Wjk. We will use these as a cover.
    let Ujk : opens α := (OC.Uis j) ∩ (OC.Uis k),
    let BUjk := Bstd.2 (OC.BUis j) (OC.BUis k),
    -- Again, all the information we will need but on Uj ∩ Uk.
    let Hjk := λ (HxUjk : Ujk), quotient.eq.1 (Hstalks HxUjk.2),
    let Wjk := λ (HxUjk : Ujk), some (Hjk HxUjk) ∩ U,
    let BWjk := λ (HxUjk : Ujk), Bstd.2 (some (some_spec (Hjk HxUjk))) BU,
    let HxWjk := λ (HxUjk : Ujk), some (some_spec (some_spec (Hjk HxUjk))),
    let HWjkUj := λ (HxUjk : Ujk), some (some_spec (some_spec (some_spec (Hjk HxUjk)))),
    let HWjkUk := λ (HxUjk : Ujk), some (some_spec (some_spec (some_spec (some_spec (Hjk HxUjk))))),
    let HWjk := λ (HxUjk : Ujk), some_spec (some_spec (some_spec (some_spec (some_spec (Hjk HxUjk))))),
    let OCjk : covering_standard_basis B ((OC.Uis j) ∩ (OC.Uis k)) :=
    { γ := Ujk,
      Uis := Wjk,
      BUis := BWjk,
      Hcov :=
        begin
          ext z,
          split,
          { rintros ⟨W, ⟨⟨OW, ⟨⟨i, HWi⟩, HWival⟩⟩, HzW⟩⟩,
            rw [←HWival, ←HWi] at HzW,
            have HzUj := (HWjkUj i) HzW.1,
            have HzUk := (HWjkUk i) HzW.1,
            exact ⟨⟨HzUj, HzW.2⟩, ⟨HzUk, HzW.2⟩⟩, },
          { intros Hz,
            use [(some (Hjk ⟨z, Hz⟩) ∩ U).val],
            have Hin : (some (Hjk ⟨z, Hz⟩) ∩ U).val
              ∈ subtype.val '' set.range (λ (HxUjk : Ujk), ((some (Hjk HxUjk) ∩ U : opens α))),
              use [(some (Hjk ⟨z, Hz⟩) ∩ U : opens α)],
              split,
              { use ⟨z, Hz⟩, },
              { refl, },
            use Hin,
            have HzWjk := HxWjk ⟨z, Hz⟩,
            have HzU := Hz.1.2,
            exact ⟨HzWjk, HzU⟩, }
        end, },
    apply (HF BUjk OCjk).1,
    intros i,
    rw ←presheaf_on_basis.Hcomp',
    rw ←presheaf_on_basis.Hcomp',
    have Hres :
        F.res (some (some_spec (Hjk i))) (BWjk i) (set.inter_subset_left _ _)
          (F.res (BV j) (some (some_spec (Hjk i))) (HWjkUj i) (σ j))
      = F.res (some (some_spec (Hjk i))) (BWjk i) (set.inter_subset_left _ _)
          (F.res (BV k) (some (some_spec (Hjk i))) (HWjkUk i) (σ k)),
      rw (HWjk i),
    rw ←presheaf_on_basis.Hcomp' at Hres,
    rw ←presheaf_on_basis.Hcomp' at Hres,
    use Hres,
  -- Ready to prove it.
  rcases (Hglue Hsx) with ⟨S, HS⟩,
  existsi S,
  apply subtype.eq,
  dsimp [to_presheaf_of_rings_extension],
  apply funext,
  intros x,
  dsimp [to_stalk_product],
  apply funext,
  intros Hx,
  replace HS := HS ⟨x, Hx⟩,
  dsimp [sx, res] at HS,
  rw Hσ ⟨x, Hx⟩,
  swap,
  { exact ⟨Hx, HxV ⟨x, Hx⟩⟩, },
  dsimp,
  apply quotient.sound,
  use [(V ⟨x, Hx⟩) ∩ U],
  use [Bstd.2 (BV ⟨x, Hx⟩) BU],
  use [⟨HxV ⟨x, Hx⟩, Hx⟩],
  use [set.inter_subset_right _ _],
  use [set.inter_subset_left _ _],
  dsimp,
  erw HS,
end

lemma to_presheaf_of_rings_extension.bijective
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: function.bijective (to_presheaf_of_rings_extension Bstd F BU) :=
⟨to_presheaf_of_rings_extension.injective Bstd F (λ U BU OC, HF BU OC) BU,
to_presheaf_of_rings_extension.surjective Bstd F (λ U BU OC, HF BU OC) BU ⟩

-- We now that they are equivalent as sets.
-- Now we to assert that they're isomorphic as rings.
-- It suffices to show that it is a ring homomorphism.

lemma to_presheaf_of_rings_extension.is_ring_hom
(F : presheaf_of_rings_on_basis α HB)
{U : opens α} (BU : U ∈ B)
: is_ring_hom (to_presheaf_of_rings_extension Bstd F BU) :=
{ map_one :=
    begin
      apply subtype.eq,
      funext x Hx,
      apply quotient.sound,
      use [U, BU, Hx, set.subset.refl _, set.subset_univ _],
      iterate 2 { erw (F.res_is_ring_hom _ _ _).map_one, },
    end,
  map_mul :=
    begin
      intros x y,
      apply subtype.eq,
      funext z Hz,
      apply quotient.sound,
      use [U, BU, Hz],
      use [set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _)],
      erw ←(F.res_is_ring_hom _ _ _).map_mul,
      erw ←presheaf_on_basis.Hcomp',
    end,
  map_add :=
    begin
      intros x y,
      apply subtype.eq,
      funext z Hz,
      apply quotient.sound,
      use [U, BU, Hz],
      use [set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _)],
      erw ←(F.res_is_ring_hom _ _ _).map_add,
      erw ←presheaf_on_basis.Hcomp',
    end, }

def to_presheaf_of_rings_extension.ring_equiv
(F : presheaf_of_rings_on_basis α HB)
(HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
{U : opens α} (BU : U ∈ B)
: F BU ≃+* (presheaf_of_rings_extension Bstd F) U :=
@@ring_equiv.of' _ _
  (equiv.of_bijective $ to_presheaf_of_rings_extension.bijective Bstd F @HF BU)
  (to_presheaf_of_rings_extension.is_ring_hom Bstd F BU)

-- Moreover, for all x, Fₓ ≅ Fextₓ.

-- We will need this to show that the stalks of the structure sheaf on
-- Spec(R) are local rings.

open stalk_of_rings_on_standard_basis

def to_stalk_extension
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: stalk_of_rings_on_standard_basis Bstd F x → stalk_of_rings (F ᵣₑₓₜ Bstd) x :=
begin
  intros BUs,
  let Us := quotient.out BUs,
  exact ⟦{U := Us.U,
          HxU := Us.Hx,
          s := (to_presheaf_of_rings_extension Bstd F Us.BU) Us.s}⟧,
end

lemma to_stalk_extension.injective
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: function.injective (to_stalk_extension Bstd F x) :=
begin
  intros Us₁' Us₂',
  apply quotient.induction_on₂ Us₁' Us₂',
  rintros Us₁ Us₂ HUs,
  rcases (quotient.mk_out Us₁) with ⟨W₁, BW₁, HxW₁, HW₁Us₁, HW₁U₁, Hres₁⟩,
  rcases (quotient.mk_out Us₂) with ⟨W₂, BW₂, HxW₂, HW₂Us₂, HW₂U₂, Hres₂⟩,
  dunfold to_stalk_extension at HUs,
  rw quotient.eq at HUs,
  rcases HUs with ⟨W, HxW, HWU₁, HWU₂, Hres⟩,
  dsimp at HWU₁,
  dsimp at HWU₂,
  dunfold to_presheaf_of_rings_extension at Hres,
  dunfold to_stalk_product at Hres,
  erw subtype.mk.inj_eq at Hres,
  replace Hres := congr_fun (congr_fun Hres x) HxW,
  dsimp at Hres,
  rw quotient.eq at Hres,
  rcases Hres with ⟨W₃, BW₃, HxW₃, HW₃U₁, HW₃U₂, Hres₃⟩,
  dsimp at HW₃U₁,
  dsimp at HW₃U₂,
  dsimp at Hres₃,
  apply quotient.sound,
  have BW₁₂₃ : W₁ ∩ W₂ ∩ W₃ ∈ B := Bstd.2 (Bstd.2 BW₁ BW₂) BW₃,
  have HW₁₂₃U₁ : W₁ ∩ W₂ ∩ W₃ ⊆ Us₁.U := λ x Hx, HW₁U₁ Hx.1.1,
  have HW₁₂₃U₂ : W₁ ∩ W₂ ∩ W₃ ⊆ Us₂.U := λ x Hx, HW₂U₂ Hx.1.2,
  use [W₁ ∩ W₂ ∩ W₃, BW₁₂₃, ⟨⟨HxW₁, HxW₂⟩, HxW₃⟩, HW₁₂₃U₁, HW₁₂₃U₂],
  have HW₁W₁₂₃ : W₁ ∩ W₂ ∩ W₃ ⊆ W₁ := λ x Hx, Hx.1.1,
  have HW₂W₁₂₃ : W₁ ∩ W₂ ∩ W₃ ⊆ W₂ := λ x Hx, Hx.1.2,
  have HW₃W₁₂₃ : W₁ ∩ W₂ ∩ W₃ ⊆ W₃ := λ x Hx, Hx.2,
  replace Hres₁ := congr_arg (F.res BW₁ BW₁₂₃ HW₁W₁₂₃) Hres₁,
  replace Hres₂ := congr_arg (F.res BW₂ BW₁₂₃ HW₂W₁₂₃) Hres₂,
  replace Hres₃ := congr_arg (F.res BW₃ BW₁₂₃ HW₃W₁₂₃) Hres₃,
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₂, },
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₃, },
  erw [←Hres₁, ←Hres₂],
  exact Hres₃,
end

lemma to_stalk_extension.surjective
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: function.surjective (to_stalk_extension Bstd F x) :=
begin
  intros Us',
  apply quotient.induction_on Us',
  rintros ⟨U, HxU, s⟩,
  rcases (s.2 x HxU) with ⟨V, BV, HxV, t, Ht⟩,
  let Vt : stalk_on_basis.elem (F.to_presheaf_on_basis) x
    := {U := V, BU := BV, Hx := HxV, s := t},
  use ⟦Vt⟧,
  dunfold to_stalk_extension,
  apply quotient.sound,
  rcases (quotient.mk_out Vt) with ⟨W, BW, HxW, HWVtV, HWV, Hres⟩,
  have HUVWV : U ∩ V ∩ W ⊆ (quotient.out ⟦Vt⟧).U := λ x Hx, HWVtV Hx.2,
  have HUVWU : U ∩ V ∩ W ⊆ U := λ x Hx, Hx.1.1,
  use [U ∩ V ∩ W, ⟨⟨HxU, HxV⟩, HxW⟩, HUVWV, HUVWU],
  apply subtype.eq,
  dsimp only [presheaf_of_rings_extension],
  dsimp only [to_presheaf_of_rings_extension],
  dsimp only [to_stalk_product],
  funext y Hy,
  rw (Ht y Hy.1),
  apply quotient.sound,
  have BVW : V ∩ W ∈ B := Bstd.2 BV BW,
  have HVWVtV : V ∩ W ⊆ (quotient.out ⟦Vt⟧).U := λ x Hx, HWVtV Hx.2,
  have HVWV : V ∩ W ⊆ V := λ x Hx, Hx.1,
  use [V ∩ W, BVW, ⟨Hy.1.2,Hy.2⟩, HVWVtV, HVWV],
  have HVWW : V ∩ W ⊆ W := λ x Hx, Hx.2,
  replace Hres := congr_arg (F.res BW BVW HVWW) Hres,
  iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres, },
  exact Hres,
end

lemma to_stalk_extension.bijective
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: function.bijective (to_stalk_extension Bstd F x) :=
⟨to_stalk_extension.injective Bstd F x,
to_stalk_extension.surjective Bstd F x⟩

lemma to_stalk_extension.is_ring_hom
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: is_ring_hom (to_stalk_extension Bstd F x) :=
{ map_one :=
    begin
      dunfold to_stalk_extension,
      let one.elem : stalk_on_basis.elem F.to_presheaf_on_basis x
        := {U := opens.univ, BU := Bstd.1, Hx := trivial, s:= 1},
      let one.stalk : stalk_of_rings_on_standard_basis Bstd F x := ⟦one.elem⟧,
      let one := quotient.out one.stalk,
      apply quotient.sound,
      rcases (quotient.mk_out one.elem) with ⟨W₁, BW₁, HxW₁, HW₁Uout, HW₁U, Hres₁⟩,
      have BUW₁ : one.U ∩ W₁ ∈ B := Bstd.2 one.BU BW₁,
      have HUUW₁ : one.U ∩ W₁ ⊆ one.U := set.inter_subset_left _ _,
      use [one.U ∩ W₁, ⟨one.Hx, HxW₁⟩, HUUW₁, set.subset_univ _],
      apply subtype.eq,
      dsimp only [presheaf_of_rings_extension],
      dsimp only [to_presheaf_of_rings_extension],
      dsimp only [to_stalk_product],
      funext z Hz,
      apply quotient.sound,
      use [one.U ∩ W₁, BUW₁, Hz, set.inter_subset_left _ _, set.subset_univ _],
      dsimp,
      have HUW₁W₁ : one.U ∩ W₁ ⊆ W₁ := set.inter_subset_right _ _,
      replace Hres₁ := congr_arg (F.res BW₁ BUW₁ HUW₁W₁) Hres₁,
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
      exact Hres₁,
    end,
  map_mul :=
    begin
      intros y z,
      apply quotient.induction_on₂ y z,
      intros Us₁ Us₂,
      simp,
      let Us₃ : stalk_on_basis.elem F.to_presheaf_on_basis x :=
        { U := Us₁.U ∩ Us₂.U,
          BU := Bstd.2 Us₁.BU Us₂.BU,
          Hx := ⟨Us₁.Hx, Us₂.Hx⟩,
          s :=  F.res Us₁.BU _ (set.inter_subset_left _ _) Us₁.s *
                F.res Us₂.BU _ (set.inter_subset_right _ _) Us₂.s },
      dunfold to_stalk_extension,
      apply quotient.sound,
      rcases (quotient.mk_out Us₁) with ⟨W₁, BW₁, HxW₁, HW₁U₁out, HW₁U₁, Hres₁⟩,
      rcases (quotient.mk_out Us₂) with ⟨W₂, BW₂, HxW₂, HW₂U₂out, HW₂U₂, Hres₂⟩,
      rcases (quotient.mk_out Us₃) with ⟨W₃, BW₃, HxW₃, HW₃U₃out, HW₃U₃, Hres₃⟩,
      let W := W₁ ∩ W₂ ∩ W₃,
      have HxW : x ∈ W := ⟨⟨HxW₁, HxW₂⟩, HxW₃⟩,
      have HWW₁ : W ⊆ W₁ := λ x Hx, Hx.1.1,
      have HWW₂ : W ⊆ W₂ := λ x Hx, Hx.1.2,
      have HWW₃ : W ⊆ W₃ := λ x Hx, Hx.2,
      have HWU₁out : W ⊆ (quotient.out ⟦Us₁⟧).U := set.subset.trans HWW₁ HW₁U₁out,
      have HWU₂out : W ⊆ (quotient.out ⟦Us₂⟧).U := set.subset.trans HWW₂ HW₂U₂out,
      have HWU₃out : W ⊆ (quotient.out ⟦Us₃⟧).U := set.subset.trans HWW₃ HW₃U₃out,
      have HWU₁₂out : W ⊆ (quotient.out ⟦Us₁⟧).U ∩ (quotient.out ⟦Us₂⟧).U
        := set.subset_inter HWU₁out HWU₂out,
      use [W, HxW, HWU₃out, HWU₁₂out],
      apply subtype.eq,
      dsimp only [presheaf_of_rings_extension],
      dsimp only [to_presheaf_of_rings_extension],
      dsimp only [to_stalk_product],
      funext z HzW,
      apply quotient.sound,
      have BW : W ∈ B := Bstd.2 (Bstd.2 BW₁ BW₂) BW₃,
      use [W, BW, HzW, HWU₃out, HWU₁₂out],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_mul,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
      replace Hres₁ := congr_arg (F.res BW₁ BW HWW₁) Hres₁,
      replace Hres₂ := congr_arg (F.res BW₂ BW HWW₂) Hres₂,
      replace Hres₃ := congr_arg (F.res BW₃ BW HWW₃) Hres₃,
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₂, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₃, },
      erw [Hres₁, Hres₂, Hres₃],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_mul,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
    end,
  map_add :=
    begin
      intros y z,
      apply quotient.induction_on₂ y z,
      intros Us₁ Us₂,
      simp,
      let Us₃ : stalk_on_basis.elem F.to_presheaf_on_basis x :=
        { U := Us₁.U ∩ Us₂.U,
          BU := Bstd.2 Us₁.BU Us₂.BU,
          Hx := ⟨Us₁.Hx, Us₂.Hx⟩,
          s :=  F.res Us₁.BU _ (set.inter_subset_left _ _) Us₁.s +
                F.res Us₂.BU _ (set.inter_subset_right _ _) Us₂.s },
      dunfold to_stalk_extension,
      apply quotient.sound,
      rcases (quotient.mk_out Us₁) with ⟨W₁, BW₁, HxW₁, HW₁U₁out, HW₁U₁, Hres₁⟩,
      rcases (quotient.mk_out Us₂) with ⟨W₂, BW₂, HxW₂, HW₂U₂out, HW₂U₂, Hres₂⟩,
      rcases (quotient.mk_out Us₃) with ⟨W₃, BW₃, HxW₃, HW₃U₃out, HW₃U₃, Hres₃⟩,
      let W := W₁ ∩ W₂ ∩ W₃,
      have HxW : x ∈ W := ⟨⟨HxW₁, HxW₂⟩, HxW₃⟩,
      have HWW₁ : W ⊆ W₁ := λ x Hx, Hx.1.1,
      have HWW₂ : W ⊆ W₂ := λ x Hx, Hx.1.2,
      have HWW₃ : W ⊆ W₃ := λ x Hx, Hx.2,
      have HWU₁out : W ⊆ (quotient.out ⟦Us₁⟧).U := set.subset.trans HWW₁ HW₁U₁out,
      have HWU₂out : W ⊆ (quotient.out ⟦Us₂⟧).U := set.subset.trans HWW₂ HW₂U₂out,
      have HWU₃out : W ⊆ (quotient.out ⟦Us₃⟧).U := set.subset.trans HWW₃ HW₃U₃out,
      have HWU₁₂out : W ⊆ (quotient.out ⟦Us₁⟧).U ∩ (quotient.out ⟦Us₂⟧).U
        := set.subset_inter HWU₁out HWU₂out,
      use [W, HxW, HWU₃out, HWU₁₂out],
      apply subtype.eq,
      dsimp only [presheaf_of_rings_extension],
      dsimp only [to_presheaf_of_rings_extension],
      dsimp only [to_stalk_product],
      funext z HzW,
      apply quotient.sound,
      have BW : W ∈ B := Bstd.2 (Bstd.2 BW₁ BW₂) BW₃,
      use [W, BW, HzW, HWU₃out, HWU₁₂out],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_add,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
      replace Hres₁ := congr_arg (F.res BW₁ BW HWW₁) Hres₁,
      replace Hres₂ := congr_arg (F.res BW₂ BW HWW₂) Hres₂,
      replace Hres₃ := congr_arg (F.res BW₃ BW HWW₃) Hres₃,
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₁, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₂, },
      iterate 2 { rw ←presheaf_on_basis.Hcomp' at Hres₃, },
      erw [Hres₁, Hres₂, Hres₃],
      rw (presheaf_of_rings_on_basis.res_is_ring_hom _ _ _ _).map_add,
      rw ←presheaf_on_basis.Hcomp',
      rw ←presheaf_on_basis.Hcomp',
    end, }

lemma to_stalk_extension.ring_equiv
(F : presheaf_of_rings_on_basis α HB)
(x : α)
: stalk_of_rings_on_standard_basis Bstd F x ≃+*
stalk_of_rings (presheaf_of_rings_extension Bstd F) x :=
begin
  have H := function.bijective_iff_has_inverse.1 (to_stalk_extension.bijective Bstd F x),
  rcases (classical.indefinite_description _ H) with ⟨inv, Hlinv, Hrinv⟩,
  use [(to_stalk_extension Bstd F x), inv, Hlinv, Hrinv],
  { apply (to_stalk_extension.is_ring_hom Bstd F x).map_mul, },
  { apply (to_stalk_extension.is_ring_hom Bstd F x).map_add, }
end

end extension_coincides

end presheaf_of_rings_extension


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.category.Top.adjunctions
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes u

namespace Mathlib

namespace Top

theorem epi_iff_surjective {X : Top} {Y : Top} (f : X ⟶ Y) : category_theory.epi f ↔ function.surjective ⇑f := sorry

theorem mono_iff_injective {X : Top} {Y : Top} (f : X ⟶ Y) : category_theory.mono f ↔ function.injective ⇑f := sorry


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.eq_to_hom

/-!
# Cartesian products of categories

We define the category instance on `C × D` when `C` and `D` are categories.

We define:
* `sectl C Z` : the functor `C ⥤ C × D` given by `X ↦ ⟨X, Z⟩`
* `sectr Z D` : the functor `D ⥤ C × D` given by `Y ↦ ⟨Z, Y⟩`
* `fst`       : the functor `⟨X, Y⟩ ↦ X`
* `snd`       : the functor `⟨X, Y⟩ ↦ Y`
* `swap`      : the functor `C × D ⥤ D × C` given by `⟨X, Y⟩ ↦ ⟨Y, X⟩`
    (and the fact this is an equivalence)

We further define `evaluation : C ⥤ (C ⥤ D) ⥤ D` and `evaluation_uncurried : C × (C ⥤ D) ⥤ D`,
and products of functors and natural transformations, written `F.prod G` and `α.prod β`.
-/

namespace category_theory

-- declare the `v`'s first; see `category_theory.category` for an explanation
universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

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

/--
`prod C D` gives the cartesian product of two categories.

See https://stacks.math.columbia.edu/tag/001K.
-/
@[simps {not_recursive := []}] -- the generates simp lemmas like `id_fst` and `comp_snd`
instance prod : category.{max v₁ v₂} (C × D) :=
{ hom     := λ X Y, ((X.1) ⟶ (Y.1)) × ((X.2) ⟶ (Y.2)),
  id      := λ X, ⟨ 𝟙 (X.1), 𝟙 (X.2) ⟩,
  comp    := λ _ _ _ f g, (f.1 ≫ g.1, f.2 ≫ g.2) }

/-- Two rfl lemmas that cannot be generated by `@[simps]`. -/
@[simp]

end

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]
/--
`prod.category.uniform C D` is an additional instance specialised so both factors have the same
universe levels. This helps typeclass resolution.
-/
instance uniform_prod : category (C × D) := category_theory.prod C D
end

-- Next we define the natural functors into and out of product categories. For now this doesn't
-- address the universal properties.
namespace prod

/-- `sectl C Z` is the functor `C ⥤ C × D` given by `X ↦ (X, Z)`. -/
@[simps] def sectl
  (C : Type u₁) [category.{v₁} C] {D : Type u₂} [category.{v₂} D] (Z : D) : C ⥤ C × D :=
{ obj := λ X, (X, Z),
  map := λ X Y f, (f, 𝟙 Z) }

/-- `sectr Z D` is the functor `D ⥤ C × D` given by `Y ↦ (Z, Y)` . -/
@[simps] def sectr
  {C : Type u₁} [category.{v₁} C] (Z : C) (D : Type u₂) [category.{v₂} D] : D ⥤ C × D :=
{ obj := λ X, (Z, X),
  map := λ X Y f, (𝟙 Z, f) }

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

/-- `fst` is the functor `(X, Y) ↦ X`. -/
@[simps] def fst : C × D ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.1 }

/-- `snd` is the functor `(X, Y) ↦ Y`. -/
@[simps] def snd : C × D ⥤ D :=
{ obj := λ X, X.2,
  map := λ X Y f, f.2 }

/-- The functor swapping the factors of a cartesian product of categories, `C × D ⥤ D × C`. -/
@[simps] def swap : C × D ⥤ D × C :=
{ obj := λ X, (X.2, X.1),
  map := λ _ _ f, (f.2, f.1) }

/--
Swapping the factors of a cartesion product of categories twice is naturally isomorphic
to the identity functor.
-/
@[simps] def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C × D) :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }

/--
The equivalence, given by swapping factors, between `C × D` and `D × C`.
-/
@[simps]
def braiding : C × D ≌ D × C :=
equivalence.mk (swap C D) (swap D C)
  (nat_iso.of_components (λ X, eq_to_iso (by simp)) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by simp)) (by tidy))

instance swap_is_equivalence : is_equivalence (swap C D) :=
(by apply_instance : is_equivalence (braiding C D).functor)

end prod

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

/--
The "evaluation at `X`" functor, such that
`(evaluation.obj X).obj F = F.obj X`,
which is functorial in both `X` and `F`.
-/
@[simps] def evaluation : C ⥤ (C ⥤ D) ⥤ D :=
{ obj := λ X,
  { obj := λ F, F.obj X,
    map := λ F G α, α.app X, },
  map := λ X Y f,
  { app := λ F, F.map f,
    naturality' := λ F G α, eq.symm (α.naturality f) } }

/--
The "evaluation of `F` at `X`" functor,
as a functor `C × (C ⥤ D) ⥤ D`.
-/
@[simps] def evaluation_uncurried : C × (C ⥤ D) ⥤ D :=
{ obj := λ p, p.2.obj p.1,
  map := λ x y f, (x.2.map f.1) ≫ (f.2.app y.1),
  map_comp' := λ X Y Z f g,
  begin
    cases g, cases f, cases Z, cases Y, cases X,
    simp only [prod_comp, nat_trans.comp_app, functor.map_comp, category.assoc],
    rw [←nat_trans.comp_app, nat_trans.naturality, nat_trans.comp_app,
        category.assoc, nat_trans.naturality],
  end }

end

variables {A : Type u₁} [category.{v₁} A]
          {B : Type u₂} [category.{v₂} B]
          {C : Type u₃} [category.{v₃} C]
          {D : Type u₄} [category.{v₄} D]

namespace functor
/-- The cartesian product of two functors. -/
@[simps] def prod (F : A ⥤ B) (G : C ⥤ D) : A × C ⥤ B × D :=
{ obj := λ X, (F.obj X.1, G.obj X.2),
  map := λ _ _ f, (F.map f.1, G.map f.2) }

/- Because of limitations in Lean 3's handling of notations, we do not setup a notation `F × G`.
   You can use `F.prod G` as a "poor man's infix", or just write `functor.prod F G`. -/

end functor

namespace nat_trans

/-- The cartesian product of two natural transformations. -/
@[simps] def prod {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) :
  F.prod H ⟶ G.prod I :=
{ app         := λ X, (α.app X.1, β.app X.2),
  naturality' := λ X Y f,
  begin
    cases X, cases Y,
    simp only [functor.prod_map, prod.mk.inj_iff, prod_comp],
    split; rw naturality
  end }

/- Again, it is inadvisable in Lean 3 to setup a notation `α × β`;
   use instead `α.prod β` or `nat_trans.prod α β`. -/

end nat_trans

end category_theory


import category_theory.category.ulift
import category_theory.limits.filtered_colimit_commutes_finite_limit -- todo: minimize imports
import data.real.nnreal

noncomputable theory
open_locale nnreal

open category_theory

namespace category_theory.limits

variables (ι : ℕ →o ℝ≥0) (hι : ∀ r : ℝ≥0, ∃ n : ℕ, r ≤ ι n)

def find_nat (r : ℝ≥0) : ℕ := (hι r).some

lemma find_nat_spec (r : ℝ≥0) : r ≤ ι (find_nat ι hι r) :=
(hι r).some_spec

def nat_to_nnreal : ℕ ⥤ ℝ≥0 :=
{ obj := λ i, ι i,
  map := λ i j h, hom_of_le $ ι.mono h.le }

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

def restrict_diagram (F : as_small.{v} ℝ≥0 ⥤ C) :
  as_small.{v} ℕ ⥤ C :=
(as_small.down ⋙ nat_to_nnreal ι ⋙ as_small.up) ⋙ F

def restrict_cocone {F : as_small.{v} ℝ≥0 ⥤ C} (S : cocone F) :
  cocone (restrict_diagram ι F) :=
S.whisker _

def is_colimit_restrict_cocone {F : as_small.{v} ℝ≥0 ⥤ C} (S : cocone F) (hS : is_colimit S) :
  is_colimit (restrict_cocone ι S) :=
{ desc := λ T, hS.desc ⟨T.X,
  { app := λ r, F.map (as_small.up.map $ hom_of_le $ find_nat_spec ι hι (ulift.down r)) ≫
        T.ι.app (ulift.up (find_nat ι hι (ulift.down r))),
    naturality' := begin
      intros r s f,
      dsimp,
      let m := find_nat ι hι (ulift.down r) ⊔ find_nat ι hι (ulift.down s),
      let r' := as_small.up.obj (find_nat ι hι (ulift.down r)),
      let s' := as_small.up.obj (find_nat ι hι (ulift.down s)),
      let m' := as_small.up.obj m,
      let ιr : r' ⟶ m' := as_small.up.map (hom_of_le $ le_sup_left),
      let ιs : s' ⟶ m' := as_small.up.map (hom_of_le $ le_sup_right),
      erw ← T.w ιr,
      erw ← T.w ιs,
      dsimp [restrict_diagram],
      simp only [category.comp_id, ← category.assoc, ← F.map_comp],
      refl,
    end }⟩,
  fac' := begin
    intros W j,
    dsimp [restrict_cocone],
    rw hS.fac,
    dsimp,
    let r := (nat_to_nnreal ι).obj (ulift.down j),
    let k := find_nat ι hι r,
    let l := (ulift.down j) ⊔ k,
    let k' : as_small.{v} ℕ := as_small.up.obj k,
    let l' : as_small.{v} ℕ := as_small.up.obj l,
    let ιk : k' ⟶ l' := as_small.up.map (hom_of_le $ le_sup_right),
    let ιj : j ⟶ l' := as_small.up.map (hom_of_le $ le_sup_left),
    erw ← W.w ιk,
    erw ← W.w ιj,
    dsimp [restrict_diagram],
    simp only [← category.assoc, ← F.map_comp],
    refl,
  end,
  uniq' := begin
    intros W m hm,
    apply hS.hom_ext, intros j,
    specialize hm (as_small.up.obj (find_nat ι hι (ulift.down j))),
    dsimp [restrict_cocone] at hm,
    rw hS.fac,
    dsimp,
    erw [← hm, ← category.assoc, S.w],
  end }

end category_theory.limits


import justification pump1 common_meta property_catalogue.LTL
 open S A

 @[reducible] def pump1_input_1 : property.input (path pump1) := {property.input .
 Clm := {Claim .
         X := {x : path pump1 | true},
         P := λ (p : path pump1), p⊨absent.after_until ↑BolusRequest ↑Cond_6_3_ ↑Infusion_NormalOperation},
 Props := [λ (p : path pump1), p⊨responds.globally ↑Cond_6_3_ ↑Alrm_EmptyReservoir, λ (p : path pump1),
              p⊨absent.between ↑BolusRequest ↑Cond_6_3_ ↑Alrm_EmptyReservoir, λ (p : path pump1),
              p⊨absent.after_until ↑BolusRequest ↑Alrm_EmptyReservoir ↑Infusion_NormalOperation]}

 @[reducible] def pump1_strat_1 : Strategy (path pump1) := property.strategy pump1_input_1

theorem pump1_prf_1 : deductive (path pump1) pump1_strat_1 :=
begin
analyze 3,
 apply absent.after_until.from_absent_between_response,
 match_premises,
end

--responds.globally ↑Cond_6_3_ ↑Alrm_EmptyReservoir


import category_theory.preadditive.additive_functor
import category_theory.limits.preserves.shapes.biproducts

import for_mathlib.derived.les2
import for_mathlib.derived.les_facts
import for_mathlib.derived.Ext_lemmas

import for_mathlib.is_quasi_iso
import for_mathlib.short_exact
import for_mathlib.homology
import for_mathlib.exact_lift_desc
import for_mathlib.additive_functor
import for_mathlib.homotopy_category_lemmas
import for_mathlib.homology_lift_desc

.

noncomputable theory

open category_theory category_theory.limits opposite
open homotopy_category (hiding single)
open bounded_homotopy_category

universes v v' u u'

-- main proof in this file is inspired by https://math.stackexchange.com/a/2118042

section

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {ι : Type*} {c : complex_shape ι}

def delta_to_kernel (C : homological_complex 𝓐 c) (i j k : ι) :
  C.X i ⟶ kernel (C.d j k) :=
factor_thru_image _ ≫ image_to_kernel' (C.d i j) _ (C.d_comp_d _ _ _)

def delta_to_kernel_ι (C : homological_complex 𝓐 c) (i j k : ι) :
  delta_to_kernel C i j k ≫ kernel.ι (C.d j k) = C.d i j :=
begin
  delta delta_to_kernel image_to_kernel',
  rw [category.assoc, kernel.lift_ι, image.fac],
end

def d_delta_to_kernel (C : homological_complex 𝓐 c) (h i j k : ι) :
  C.d h i ≫ delta_to_kernel C i j k = 0 :=
begin
  rw [← cancel_mono (kernel.ι (C.d j k)), category.assoc, delta_to_kernel_ι, C.d_comp_d, zero_comp],
end

-- move me
lemma short_exact_comp_iso {A B C D : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (h : C ⟶ D) (hh : is_iso h) :
  short_exact f (g ≫ h) ↔ short_exact f g :=
begin
  split; intro H,
  { haveI : mono f := H.mono,
    haveI : epi g,
    { haveI := H.epi, have := epi_comp (g ≫ h) (inv h), simpa only [category.assoc, is_iso.hom_inv_id, category.comp_id] },
    refine ⟨_⟩, have := H.exact, rwa exact_comp_iso at this, },
  { haveI : mono f := H.mono,
    haveI : epi g := H.epi,
    haveI : epi (g ≫ h) := epi_comp g h,
    refine ⟨_⟩, have := H.exact, rwa exact_comp_iso }
end

lemma is_acyclic_def
  (C : homotopy_category 𝓐 c) :
  is_acyclic C ↔ (∀ i, is_zero (C.as.homology i)) :=
begin
  split,
  { apply is_acyclic.cond },
  { apply is_acyclic.mk }
end

lemma is_acyclic_iff_short_exact_to_cycles
  (C : homotopy_category 𝓐 (complex_shape.up ℤ)) :
  is_acyclic C ↔
  (∀ i, short_exact (kernel.ι (C.as.d i (i+1))) (delta_to_kernel C.as i (i+1) (i+1+1))) :=
begin
  rw is_acyclic_def,
  symmetry,
  apply (equiv.add_right (1 : ℤ)).forall_congr,
  intro i,
  let e := (homology_iso C.as i (i+1) (i+1+1) rfl rfl),
  dsimp [delta_to_kernel] at e ⊢,
  rw [e.is_zero_iff, homology_is_zero_iff_image_to_kernel'_is_iso],
  split,
  { apply iso_of_short_exact_comp_right _ _ _, apply short_exact_kernel_factor_thru_image },
  { intro h, rw short_exact_comp_iso _ _ _ h, apply short_exact_kernel_factor_thru_image }
end

lemma is_acyclic_iff_short_exact_to_cycles'
  (C : homological_complex 𝓐 (complex_shape.down ℤ)) :
  (∀ i, is_zero (C.homology i)) ↔
  (∀ i, short_exact (kernel.ι (C.d (i+1+1) (i+1))) (delta_to_kernel C (i+1+1) (i+1) i)) :=
begin
  symmetry,
  apply (equiv.add_right (1 : ℤ)).forall_congr,
  intro i,
  let e := (homology_iso C (i+1+1) (i+1) i rfl rfl),
  dsimp [delta_to_kernel] at e ⊢,
  rw [e.is_zero_iff, homology_is_zero_iff_image_to_kernel'_is_iso],
  split,
  { apply iso_of_short_exact_comp_right _ _ _, apply short_exact_kernel_factor_thru_image },
  { intro h, rw short_exact_comp_iso _ _ _ h, apply short_exact_kernel_factor_thru_image }
end

end

variables {𝓐 𝓑 : Type*} [category 𝓐] [abelian 𝓐] [enough_projectives 𝓐]
variables [category 𝓑] [abelian 𝓑] [enough_projectives 𝓑]

variables (C : cochain_complex 𝓐 ℤ)
  [homotopy_category.is_bounded_above ((homotopy_category.quotient _ _).obj C)]

def category_theory.functor.single (F : bounded_homotopy_category 𝓐 ⥤ 𝓑) (i : ℤ) : 𝓐 ⥤ 𝓑 :=
bounded_homotopy_category.single _ i ⋙ F

-- move me
lemma category_theory.limits.is_zero.biprod {𝓐 : Type*} [category 𝓐] [abelian 𝓐]
  {X Y : 𝓐} (hX : is_zero X) (hY : is_zero Y) :
  is_zero (X ⊞ Y) :=
begin
  rw is_zero_iff_id_eq_zero at hX hY ⊢,
  ext; simp [hX, hY],
end

instance category_theory.limits.preserves_binary_biproduct_of_additive
  {𝓐 𝓑 : Type*} [category.{v} 𝓐] [category.{v} 𝓑] [abelian 𝓐] [abelian 𝓑]
  (F : 𝓐 ⥤ 𝓑) [functor.additive F] (X Y : 𝓐) :
  preserves_binary_biproduct X Y F :=
preserves_binary_biproduct_of_preserves_biproduct _ _ _

lemma acyclic_left_of_short_exact (B : 𝓐) {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : short_exact f g)
  (hY : ∀ i > 0, is_zero (((Ext' i).obj (op $ Y)).obj B))
  (hZ : ∀ i > 0, is_zero (((Ext' i).obj (op $ Z)).obj B)) :
  ∀ i > 0, is_zero (((Ext' i).obj (op $ X)).obj B) :=
begin
  intros i hi,
  have := hfg.Ext'_five_term_exact_seq B i,
  refine (this.drop 1).pair.is_zero_of_is_zero_is_zero (hY _ hi) (hZ _ _),
  transitivity i, { exact lt_add_one i }, { exact hi }
end
.

lemma map_is_acyclic_of_acyclic_aux
  {A B C D X Y Z W : 𝓐} (f : A ⟶ B) (g : C ⟶ D) (π : B ⟶ kernel g)
  {α : X ⟶ B} {β : B ⟶ Y} {γ : Y ⟶ C} {δ : C ⟶ Z} {ε : Z ⟶ D} {ζ : D ⟶ W}
  (hαβ : short_exact α β) (hγδ : short_exact γ δ) (hεζ : short_exact ε ζ)
  (hf : mono f) (hfπ : exact f π)
  (hαπ : α ≫ π = 0) (hγg : γ ≫ g = 0) (hδε : δ ≫ ε = g)
  (hπι : π ≫ kernel.ι g = β ≫ γ) :
  short_exact f π :=
begin
  suffices : epi π, { resetI, exact ⟨hfπ⟩ },
  have hβ : epi β := hαβ.epi,
  have hγ : mono γ := hγδ.mono,
  have hε : mono ε := hεζ.mono,
  resetI,
  have hιδ : kernel.ι g ≫ δ = 0,
  { rw [← cancel_mono ε, category.assoc, hδε, kernel.condition, zero_comp], },
  let e1 : Y ⟶ kernel g := hαβ.exact.epi_desc π hαπ,
  let e2 : Y ⟶ kernel g := kernel.lift g γ hγg,
  let e3 : kernel g ⟶ Y := hγδ.exact.mono_lift (kernel.ι g) hιδ,
  have he12 : e1 = e2,
  { rw [← cancel_epi β, ← cancel_mono (kernel.ι g)],
    simp only [hπι, category.assoc, kernel.lift_ι, exact.comp_epi_desc_assoc], },
  have he13 : e1 ≫ e3 = 𝟙 _,
  { rw [he12, ← cancel_mono γ, category.assoc, exact.mono_lift_comp, kernel.lift_ι, category.id_comp], },
  have he31 : e3 ≫ e1 = 𝟙 _,
  { rw [he12, ← cancel_mono (kernel.ι g), category.assoc, kernel.lift_ι, exact.mono_lift_comp, category.id_comp], },
  let e : Y ≅ kernel g := ⟨e1, e3, he13, he31⟩,
  have hπ : β ≫ e.hom = π := exact.comp_epi_desc _ _ _,
  rw ← hπ, exact epi_comp _ _,
end

lemma short_exact_Ext_of_short_exact_of_acyclic {A B C : 𝓐} (Z : 𝓐) {f : A ⟶ B} {g : B ⟶ C}
  (hfg : short_exact f g) (hC : ∀ i > 0, is_zero (((Ext' i).obj (op $ C)).obj Z)) :
  short_exact (((Ext' 0).flip.obj Z).map g.op) (((Ext' 0).flip.obj Z).map f.op) :=
begin
  have H0 := hfg.Ext'_five_term_exact_seq Z 0,
  apply_with short_exact.mk {instances:=ff},
  { have H := ((hfg.Ext'_five_term_exact_seq Z (-1)).drop 2).pair,
    apply H.mono_of_is_zero,
    apply Ext'_is_zero_of_neg, dec_trivial },
  { apply (H0.drop 1).pair.epi_of_is_zero,
    apply hC, dec_trivial },
  { exact H0.pair }
end

lemma map_is_acyclic_of_acyclic''
  [is_acyclic ((homotopy_category.quotient _ _).obj C)]
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B)) :
  ∀ i, is_zero (((((Ext' 0).flip.obj B).map_homological_complex _).obj C.op).homology i) :=
begin
  rw is_acyclic_iff_short_exact_to_cycles',
  obtain ⟨a, ha⟩ := is_bounded_above.cond ((quotient 𝓐 (complex_shape.up ℤ)).obj C),
  have aux : ((quotient 𝓐 (complex_shape.up ℤ)).obj C).is_acyclic := ‹_›,
  rw is_acyclic_iff_short_exact_to_cycles at aux,
  intro i,
  let K := λ j, kernel (C.d j (j+1)),
  suffices hK : ∀ j, ∀ i > 0, is_zero (((Ext' i).obj (op $ K j)).obj B),
  { have SES1 := short_exact_Ext_of_short_exact_of_acyclic B (aux (i+1+1)) (hK _),
    have SES2 := short_exact_Ext_of_short_exact_of_acyclic B (aux (i+1)) (hK _),
    have SES3 := short_exact_Ext_of_short_exact_of_acyclic B (aux i) (hK _),
    apply map_is_acyclic_of_acyclic_aux _ _ _ SES1 SES2 SES3 infer_instance;
      clear SES1 SES2 SES3 aux,
    { delta delta_to_kernel image_to_kernel',
      apply exact_comp_mono, rw exact_factor_thru_image_iff, exact exact_kernel_ι },
    { rw [← cancel_mono (kernel.ι _), zero_comp, category.assoc, delta_to_kernel_ι],
      swap, apply_instance,
      erw [functor.map_homological_complex_obj_d, ← functor.map_comp],
      dsimp only [homological_complex.op_d, quotient_obj_as],
      rw [← op_comp, d_delta_to_kernel, op_zero, functor.map_zero], },
    { erw [functor.map_homological_complex_obj_d, ← functor.map_comp],
      dsimp only [homological_complex.op_d, quotient_obj_as],
      rw [← op_comp, d_delta_to_kernel, op_zero, functor.map_zero], },
    { rw [← functor.map_comp, ← op_comp, delta_to_kernel_ι], refl, },
    { rw [delta_to_kernel_ι, ← functor.map_comp, ← op_comp, delta_to_kernel_ι], refl, },
    { apply_instance } },
  clear i, intro j,
  have : ∀ j ≥ a, ∀ i > 0, is_zero (((Ext' i).obj (op $ K j)).obj B),
  { intros j hj i hi,
    apply bounded_derived_category.Ext'_zero_left_is_zero,
    apply is_zero.op,
    refine is_zero.of_mono (kernel.ι _) _,
    exact ha j hj },
  apply int.induction_on' j a,
  { exact this _ le_rfl, },
  { intros j hj aux, apply this, exact int.le_add_one hj, },
  { intros j hj IH,
    obtain ⟨j, rfl⟩ : ∃ i, i + 1 = j := ⟨j - 1, sub_add_cancel _ _⟩,
    rw add_sub_cancel,
    apply acyclic_left_of_short_exact B (kernel.ι _) (delta_to_kernel _ _ _ _) _ (hC _) IH,
    exact aux j, }
end

lemma map_is_acyclic_of_acyclic'
  [is_acyclic ((homotopy_category.quotient _ _).obj C)]
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B)) :
  is_acyclic ((((Ext' 0).flip.obj B).right_op.map_homotopy_category _).obj ((homotopy_category.quotient _ _).obj C)) :=
begin
  rw is_acyclic_def,
  intro i,
  have h1 : (complex_shape.up ℤ).rel (i - 1) i, { dsimp, apply sub_add_cancel },
  refine is_zero.of_iso _ (homology_iso' _ (i-1) i (i+1) h1 rfl),
  dsimp only [functor.map_homotopy_category_obj, quotient_obj_as,
    functor.right_op_map, functor.map_homological_complex_obj_d],
  apply exact.homology_is_zero,
  apply exact.op,
  refine exact_of_homology_is_zero _,
  { rw [← category_theory.functor.map_comp, ← op_comp, homological_complex.d_comp_d, op_zero, functor.map_zero], },
  have := map_is_acyclic_of_acyclic'' C B hC i,
  apply this.of_iso _, clear this,
  let C' := (((Ext' 0).flip.obj B).map_homological_complex (complex_shape.up ℤ).symm).obj (homological_complex.op C),
  have h1 : (complex_shape.down ℤ).rel i (i - 1), { dsimp, apply sub_add_cancel },
  exact (homology_iso' C' (i+1) i (i-1) rfl h1).symm,
end

lemma map_is_acyclic_of_acyclic
  [is_acyclic ((homotopy_category.quotient _ _).obj C)]
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B)) :
  is_acyclic (((preadditive_yoneda.obj B).right_op.map_homotopy_category _).obj ((homotopy_category.quotient _ _).obj C)) :=
begin
  have := map_is_acyclic_of_acyclic' C B hC,
  rw is_acyclic_def at this ⊢,
  intro i, specialize this i,
  apply this.of_iso _, clear this,
  have h1 : (complex_shape.up ℤ).rel (i - 1) i, { dsimp, apply sub_add_cancel },
  refine (homology_iso' _ (i-1) i (i+1) h1 rfl) ≪≫ _ ≪≫ (homology_iso' _ (i-1) i (i+1) h1 rfl).symm,
  dsimp only [functor.map_homotopy_category_obj, quotient_obj_as,
    functor.right_op_map, functor.map_homological_complex_obj_d],
  let e := λ i, ((bounded_derived_category.Ext'_zero_flip_iso _ B).app (op $ C.X i)).op,
  refine homology.map_iso _ _ (arrow.iso_mk (e _) (e _) _) (arrow.iso_mk (e _) (e _) _) rfl,
  { simp only [iso.op_hom, iso.app_hom, arrow.mk_hom, functor.flip_obj_map, ← op_comp, ← nat_trans.naturality], },
  { simp only [iso.op_hom, iso.app_hom, arrow.mk_hom, functor.flip_obj_map, ← op_comp, ← nat_trans.naturality], },
end

lemma acyclic_of_projective (P B : 𝓐) [projective P] (i : ℤ) (hi : 0 < i) :
  is_zero (((Ext' i).obj (op P)).obj B) :=
begin
  rw (Ext'_iso (op P) B i _ (𝟙 _) _).is_zero_iff,
  { rcases i with ((_|i)|i),
    { exfalso, revert hi, dec_trivial },
    swap, { exfalso, revert hi, dec_trivial },
    refine is_zero.homology_is_zero _ _ _ _,
    apply AddCommGroup.is_zero_of_eq,
    intros,
    apply is_zero.eq_of_src,
    apply is_zero_zero, },
  { refine ⟨_, _, _⟩,
    { rintro (_|n), { assumption }, { dsimp, apply_instance } },
    { exact exact_zero_mono (𝟙 P) },
    { rintro (_|n); exact exact_of_zero 0 0 } }
end

def Ext_compute_with_acyclic_aux₁
  (B : 𝓐)
  (i : ℤ) :
  ((Ext i).obj (op $ of' C)).obj ((single _ 0).obj B) ≅
  (preadditive_yoneda.obj ((single 𝓐 (-i)).obj B)).obj (op (of' C).replace) :=
(preadditive_yoneda.map_iso $ (shift_single_iso 0 i).app B ≪≫ eq_to_iso (by rw zero_sub)).app _

abbreviation of'_hom {C₁ C₂ : cochain_complex 𝓐 ℤ}
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (f : C₁ ⟶ C₂) :
  of' C₁ ⟶ of' C₂ :=
(homotopy_category.quotient _ _).map f

lemma Ext_compute_with_acyclic_aux₁_naturality
  (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  ((Ext i).map $ quiver.hom.op $ of'_hom f).app _ ≫
    (Ext_compute_with_acyclic_aux₁ C₁ B i).hom =
  (Ext_compute_with_acyclic_aux₁ C₂ B i).hom ≫
  (preadditive_yoneda.obj _).map (quiver.hom.op $
  bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π) :=
begin
  ext F,
  dsimp [Ext, Ext_compute_with_acyclic_aux₁],
  simp only [comp_apply],
  dsimp, simp,
end

def Ext_compute_with_acyclic_aux₂
  (B : 𝓐)
  (i : ℤ) :
  (preadditive_yoneda.obj ((single 𝓐 (-i)).obj B)).obj (op (of' C).replace) ≅
  (((preadditive_yoneda.obj B).map_homological_complex (complex_shape.up ℤ).symm).obj
  ((of' C).replace).val.as.op).homology (-i) :=
  hom_single_iso _ _ _

-- TODO: We should prove naturality of `hom_single_iso` independently!
lemma Ext_compute_with_acyclic_aux₂_naturality
  (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  (preadditive_yoneda.obj _).map (quiver.hom.op $
    bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π) ≫
    (Ext_compute_with_acyclic_aux₂ C₁ B i).hom =
  (Ext_compute_with_acyclic_aux₂ C₂ B i).hom ≫
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op ⋙
      (_root_.homology_functor _ _ (-i)).op).map
      (bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π).out).unop :=
hom_single_iso_naturality _ _ _ _ _

def Ext_compute_with_acyclic_HomB
  (B : 𝓐) := (preadditive_yoneda.obj B).right_op.map_homological_complex (complex_shape.up ℤ) ⋙
  homological_complex.unop_functor.right_op

lemma Ext_compute_with_acyclic_is_quasi_iso_aux
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) :
  is_quasi_iso ((homotopy_category.quotient _ _).map
    ((Ext_compute_with_acyclic_HomB B).map (of' C).π.out).unop) :=
begin
  let P := (of' C).replace,
  let π : P ⟶ of' C := (of' C).π,
  let HomB := (preadditive_yoneda.obj B).right_op.map_homological_complex (complex_shape.up ℤ) ⋙
    homological_complex.unop_functor.right_op,
  let fq := (homotopy_category.quotient _ _).map (HomB.map π.out).unop,
  apply is_quasi_iso_of_op,
  let f := homological_complex.op_functor.map (HomB.map (quot.out π)),
  have := cone_triangleₕ_mem_distinguished_triangles _ _ f,
  replace := is_quasi_iso_iff_is_acyclic _ this,
  dsimp [homological_complex.cone.triangleₕ] at this,
  erw this, clear this i,
  constructor,
  intro i, obtain ⟨i, rfl⟩ : ∃ j, j + 1 = i := ⟨i - 1, sub_add_cancel _ _⟩,
  refine is_zero.of_iso _ (homology_iso _ i (i+1) (i+1+1) _ _),
  rotate, { dsimp, refl }, { dsimp, refl },
  apply exact.homology_is_zero _,
  dsimp only [homotopy_category.quotient, quotient.functor_obj_as, homological_complex.cone_d],
  have hπ : is_quasi_iso π, { dsimp [π], apply_instance },
  have := cone_triangleₕ_mem_distinguished_triangles _ _ π.out,
  replace := is_quasi_iso_iff_is_acyclic _ this,
  dsimp [homological_complex.cone.triangleₕ] at this,
  simp only [quotient_map_out] at this,
  replace := this.mp _,
  swap, { convert hπ using 1, generalize : P.val = X, cases X, refl, },
  haveI preaux : ((quotient 𝓐 (complex_shape.up ℤ)).obj (homological_complex.cone (quot.out π))).is_bounded_above,
  { constructor,
    obtain ⟨a, ha⟩ := is_bounded_above.cond ((quotient 𝓐 (complex_shape.up ℤ)).obj C),
    obtain ⟨b, hb⟩ := is_bounded_above.cond P.val,
    refine ⟨max a b, _⟩,
    intros k hk,
    refine category_theory.limits.is_zero.biprod _ _,
    { apply hb, refine (le_max_right _ _).trans (hk.trans (lt_add_one _).le) },
    { apply ha, exact (le_max_left _ _).trans hk, } },
  have aux := @map_is_acyclic_of_acyclic _ _ _ _ _ _ this B _,
  { replace := (@is_acyclic.cond _ _ _ _ _ _ aux (i+1)).of_iso (homology_iso _ i (i+1) (i+1+1) _ _).symm,
    rotate, { dsimp, refl }, { dsimp, refl },
    dsimp only [homotopy_category.quotient, quotient.functor_obj_as, homological_complex.cone_d,
      functor.map_homotopy_category_obj, functor.map_homological_complex_obj_d] at this,
    replace := exact_of_homology_is_zero this,
    let e := functor.map_biprod (preadditive_yoneda.obj B).right_op,
    refine preadditive.exact_of_iso_of_exact' _ _ _ _ (e _ _) (e _ _) (e _ _) _ _ this;
    dsimp only [e, functor.map_biprod_hom],
    all_goals
    { ext,
      { simp only [category.assoc, functor.right_op_map, homological_complex.cone.d, biprod.lift_fst,
          eq_self_iff_true, functor.map_homological_complex_obj_d, functor.right_op_map,
          homological_complex.X_eq_to_iso_refl, category.comp_id, dite_eq_ite, if_true,
          biprod.lift_fst, biprod.lift_desc, preadditive.comp_neg, comp_zero, add_zero],
        simp only [functor.map_homological_complex_obj_d, functor.right_op_map, functor.comp_map,
          biprod.lift_desc, preadditive.comp_neg, comp_zero, add_zero,
          ← op_comp, ← category_theory.functor.map_comp, biprod.lift_fst],
        simp only [biprod.desc_eq, comp_zero, add_zero, preadditive.comp_neg,
          category_theory.op_neg, functor.map_neg, op_comp, category_theory.functor.map_comp],
        refl },
      { simp only [category.assoc, functor.right_op_map, homological_complex.cone.d, biprod.lift_snd,
          eq_self_iff_true, functor.map_homological_complex_obj_d, functor.right_op_map,
          functor.map_homological_complex_map_f, homological_complex.X_eq_to_iso_refl,
          category.comp_id, dite_eq_ite, if_true, biprod.lift_snd, biprod.lift_desc],
        simp only [functor.map_homological_complex_obj_d, functor.right_op_map, functor.comp_map,
          biprod.lift_desc, preadditive.comp_neg, comp_zero, add_zero,
          ← op_comp, ← category_theory.functor.map_comp, biprod.lift_snd],
        simp only [biprod.desc_eq, op_add, functor.map_neg, functor.map_add, op_comp,
          category_theory.functor.map_comp],
        refl } } },
  { clear i, intros k i hi,
    let e := functor.map_biprod ((Ext' i).flip.obj B).right_op
      (P.val.as.X (k + 1)) ((of' C).val.as.X k),
    refine is_zero.of_iso (is_zero.unop _) e.symm.unop,
    refine category_theory.limits.is_zero.biprod _ _,
    { simp only [functor.right_op_obj, functor.flip_obj_obj, is_zero_op],
      exact acyclic_of_projective (P.val.as.X (k + 1)) B i hi, },
    { exact (hC k _ hi).op, }, },
end

def Ext_compute_with_acyclic_aux₃
  (B : 𝓐)
  (i : ℤ) :
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _).obj C).unop.homology (-i) ⟶
  (((preadditive_yoneda.obj B).map_homological_complex (complex_shape.up ℤ).symm).obj
  ((of' C).replace).val.as.op).homology (-i) :=
by apply (homotopy_category.homology_functor Ab _ (-i)).map
  (((homotopy_category.quotient _ _).map
    ((Ext_compute_with_acyclic_HomB B).map (of' C).π.out).unop))

-- Are these two lemmas useful? Do we have them?
lemma functor.map_unop {𝓐 : Type*} [category 𝓐] {𝓑 : Type*}
  [category 𝓑] (F : 𝓐 ⥤ 𝓑) {a₁ a₂ : 𝓐ᵒᵖ}
  (f : a₁ ⟶ a₂) : F.map f.unop = (F.op.map f).unop :=
rfl

lemma functor.map_map' {𝓐 : Type*} [category 𝓐] {𝓑 : Type*}
  [category 𝓑] {𝓒 : Type*} [category 𝓒] (F : 𝓐 ⥤ 𝓑) (G : 𝓑 ⥤ 𝓒) {a₁ a₂ : 𝓐}
  (φ : a₁ ⟶ a₂) : G.map (F.map φ) = (F ⋙ G).map φ :=
rfl

namespace Ext_compute_with_acyclic_aux₃_naturality_helpers

variables (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ)

lemma helper₁ (h1 h2) :
  homology.lift ((unop
    (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
      (complex_shape.up ℤ)).obj C₁))).d_to (-i))
  ((unop (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).obj C₁))).d_from (-i)) h1
  (kernel.ι ((unop (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).obj C₂))).d_from (-i)) ≫
    (homological_complex.unop_functor.right_op.map
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).map f)).unop.f (-i) ≫ cokernel.π
    ((unop (homological_complex.unop_functor.right_op.obj
    (((preadditive_yoneda.obj B).right_op.map_homological_complex
    (complex_shape.up ℤ)).obj C₁))).d_to (-i))) h2 =
  kernel.lift _ (kernel.ι _ ≫ (preadditive_yoneda.obj B).map (f.f (-i)).op) begin
    rw category.assoc,
    have aux := ((((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map f)).unop.comm_from (-i),
    dsimp at aux,
    erw [aux, kernel.condition_assoc, zero_comp],
  end ≫
  homology.π' _ _ _ :=
begin
  apply homology.hom_to_ext,
  rw [category.assoc, homology.π'_ι, kernel.lift_ι_assoc,
    homology.lift_ι],
  refl,
end

lemma helper₂ (h1 h2) :
  homology.lift ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).replace.val.as)).d_to (-i))
  ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).replace.val.as)).d_from (-i))
  h1
  (kernel.ι ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).val.as)).d_from (-i)) ≫
     ((Ext_compute_with_acyclic_HomB B).map (quot.out (of' C₂).π)).unop.f (-i) ≫
       cokernel.π ((unop ((Ext_compute_with_acyclic_HomB B).obj (of' C₂).replace.val.as)).d_to (-i)))
  h2 =
  kernel.lift _ (kernel.ι _ ≫ begin
    apply homological_complex.hom.f,
    exact (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map (of' C₂).π.out).unop,
  end) begin
    rw category.assoc,
    have := (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map (of' C₂).π.out).unop.comm_from (-i),
    erw [this, kernel.condition_assoc, zero_comp],
  end ≫ homology.π' _ _ _ :=
begin
  apply homology.hom_to_ext,
  simp only [homology.lift_ι, category.assoc, homology.π'_ι, kernel.lift_ι_assoc],
  refl,
end

end Ext_compute_with_acyclic_aux₃_naturality_helpers

lemma Ext_compute_with_acyclic_aux₃_naturality
  (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
    homological_complex.unop_functor.right_op ⋙ (_root_.homology_functor _ _ (-i)).op).map f).unop
    ≫ Ext_compute_with_acyclic_aux₃ C₁ B i =
  Ext_compute_with_acyclic_aux₃ C₂ B i ≫
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op ⋙
      (_root_.homology_functor _ _ (-i)).op).map
      (bounded_homotopy_category.lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π).out).unop :=
begin
  dsimp only [Ext_compute_with_acyclic_aux₃, functor.comp_map,
    _root_.homology_functor, functor.op, homological_complex.hom.sq_from,
    homological_complex.hom.sq_to, homotopy_category.quotient,
    homotopy_category.homology_functor, quotient.functor,
    category_theory.quotient.lift, quot.lift_on, quiver.hom.unop_op],
  simp_rw homology.map_eq_desc'_lift_left,
  apply homology.hom_from_ext,
  simp only [category.assoc, homology.π'_desc'_assoc],
  slice_rhs 1 2
  { erw homology.π'_desc' },
  dsimp only [arrow.hom_mk_left],
  rw Ext_compute_with_acyclic_aux₃_naturality_helpers.helper₁,
  conv_rhs { rw Ext_compute_with_acyclic_aux₃_naturality_helpers.helper₂ },
  simp only [category.assoc],
  slice_lhs 2 3
  { erw homology.π'_desc' },
  slice_rhs 2 3
  { erw homology.π'_desc' },
  apply homology.hom_to_ext,
  slice_lhs 2 3
  { erw homology.lift_ι },
  slice_rhs 2 3
  { erw homology.lift_ι },
  slice_lhs 1 2
  { erw kernel.lift_ι },
  slice_rhs 1 2
  { erw kernel.lift_ι },
  simp only [category.assoc],
  dsimp only [Ext_compute_with_acyclic_HomB, functor.comp_map],
  change _ ≫ (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op).map f).unop.f _ ≫ _ = _,
  slice_lhs 2 3
  { simp only [← homological_complex.comp_f, ← unop_comp],
    simp only [functor.comp_map, ← functor.map_comp] },
  slice_rhs 2 3
  { simp only [← homological_complex.comp_f, ← unop_comp, ← functor.map_comp] },
  apply homotopy.kernel_ι_comp_comp_cokernel_π_of_homotopy,
  apply homotopy.homotopy_unop_functor_right_op_map_unop_of_homotopy,
  apply functor.map_homotopy,
  suffices : (lift ((of' C₁).π ≫ of'_hom f) (of' C₂).π) ≫ (of' C₂).π =
    (of' C₁).π ≫ of'_hom f,
  { apply homotopy_category.homotopy_of_eq,
    convert this.symm,
    { simpa only [functor.map_comp, quotient_map_out], },
    { simpa only [functor.map_comp, quotient_map_out], } },
  simp,
end

lemma Ext_compute_with_acyclic_aux₃_is_iso
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) : is_iso (Ext_compute_with_acyclic_aux₃ C B i) :=
begin
  haveI := Ext_compute_with_acyclic_is_quasi_iso_aux C B hC i,
  apply is_quasi_iso.cond,
end

def Ext_compute_with_acyclic
  (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) :
  ((Ext i).obj (op $ of' C)).obj ((single _ 0).obj B) ≅
  (((preadditive_yoneda.obj B).right_op.map_homological_complex _).obj C).unop.homology (-i) :=
Ext_compute_with_acyclic_aux₁ C B i ≪≫
Ext_compute_with_acyclic_aux₂ _ _ _ ≪≫
begin
  haveI := Ext_compute_with_acyclic_aux₃_is_iso C B hC i,
  exact (as_iso (Ext_compute_with_acyclic_aux₃ C B i)).symm,
end

/-
def homological_complex.single_iso (B : 𝓐) {i j : ℤ} (h : j = i) :
  ((homological_complex.single _ (complex_shape.up ℤ) i).obj B).X j ≅ B :=
eq_to_iso (if_pos h)

/-- The morphism in `Ab` which eats a morphism of complexes `C ⟶ B[-i]`
  and returns an element of Extⁱ(C,B[0]). -/
def Ext_compute_with_acyclic_inv_eq_aux (B) (i) :
  AddCommGroup.of (C ⟶ (homological_complex.single _ _ (-i)).obj B) ⟶
  ((Ext i).obj (op (of' C))).obj ((single 𝓐 0).obj B) :=
{ to_fun := λ f, (of' C).π ≫ begin
    refine (homotopy_category.quotient _ _).map _,
    refine _ ≫ (homological_complex.single_shift _ _).inv.app _,
    refine (f : C ⟶ (homological_complex.single 𝓐 (complex_shape.up ℤ) (-i)).obj B) ≫ _,
    refine eq_to_hom _,
    simp,
  end,
  map_zero' := begin
    simp only [zero_comp, functor.map_zero, comp_zero],
  end,
  map_add' := begin
    intros,
    simp only [preadditive.add_comp, functor.map_add, preadditive.comp_add],
  end }

lemma iso_equiv_inv_apply_eq_zero_cancel
  {A B C : AddCommGroup} {a : A} {f : A ⟶ B} {e : C ≅ B}
  (h : (f ≫ e.inv) a = 0) : f a = 0 :=
begin
  rw comp_apply at h,
  apply_fun e.hom at h,
  simpa using h,
end

-- Note: in the application of the below, j = -i
/-- The construction which given something in the kernel of `(Cⱼ ⟶ B) ⟶ (Cⱼ-₁ ⟶ B)`
  constructs a morphism of complexes from C to the "skyscraper complex" B[j]. -/
def kernel_yoneda_complex_to_morphism_to_single (B : 𝓐) (j : ℤ) :
-- we're going from the kernel of `(C.X j ⟶ B) ⟶ (C.X_prev j ⟶ B)` (it's actually `C.symm.X_next`)
kernel ((((preadditive_yoneda.obj B).map_homological_complex _).obj
  (homological_complex.op C)).d_from j)
  -- to the additive group of homs
  ⟶ AddCommGroup.of (
  -- from C to B j
  C ⟶ (homological_complex.single 𝓐 (complex_shape.up ℤ) j).obj B) :=
{ to_fun := λ f, { f := λ k,
  if hk : k = j then
    (eq_to_hom (by rw hk) : C.X k ⟶ C.X j) ≫
    (kernel.ι ((((preadditive_yoneda.obj B).map_homological_complex _).obj
                (homological_complex.op C)).d_from j) f : C.X j ⟶ B) ≫
    (homological_complex.single_obj_X_self 𝓐 (complex_shape.up ℤ) j B).inv ≫
    eq_to_hom (by rw hk)
  else 0,
    comm' := λ i k, begin
      split_ifs with hij hkj hkj,
      { subst hij, subst hkj, simp {contextual := tt}, },
      { simp only [homological_complex.single_obj_d, comp_zero, eq_self_iff_true,
          implies_true_iff] },
      { subst hkj,
        set g := ((kernel.ι ((((preadditive_yoneda.obj B).map_homological_complex
                            (complex_shape.up ℤ).symm).obj
                  (homological_complex.op C)).d_from k)) f) with hg,
        simp only [complex_shape.up_rel, zero_comp, eq_to_hom_refl,
          homological_complex.single_obj_X_self_inv, category.comp_id, category.id_comp],
        rintro hik, clear hij,
        have := kernel.condition ((((preadditive_yoneda.obj B).map_homological_complex _).obj
          (homological_complex.op C)).d_from k),
        replace this := congr_hom this f,
        rw [comp_apply, ← hg, AddCommGroup.zero_apply] at this,
        rw ← category.assoc,
        symmetry,
        convert zero_comp,
        have foo : (complex_shape.up ℤ).symm.rel k i := hik,
        rw homological_complex.d_from_eq _ foo at this,
        exact iso_equiv_inv_apply_eq_zero_cancel this, },
      { simp only [zero_comp, comp_zero, eq_self_iff_true, implies_true_iff]},
    end },
  map_zero' := by {simp only [map_zero, homological_complex.single_obj_X_self_inv,
    eq_to_hom_trans, zero_comp, comp_zero, dite_eq_ite, if_t_t], refl },
  map_add' := by { intros, ext, simp only [map_add, homological_complex.single_obj_X_self_inv,
    eq_to_hom_trans, preadditive.add_comp, preadditive.comp_add, homological_complex.add_f_apply],
    split_ifs,
    { refl },
    { refl },
    { exact (add_zero _).symm, } } }

lemma Ext_compute_with_acylic_inv_eq (B : 𝓐)
  (hC : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C.X k)).obj B))
  (i : ℤ) :
  (Ext_compute_with_acyclic _ B hC i).inv =
  homology.desc' _ _ _
  ( kernel_yoneda_complex_to_morphism_to_single C B (-i) ≫
    Ext_compute_with_acyclic_inv_eq_aux C B i)
admit := admit

-- Replacing some `End` with `cend` fixes my bracket pair colorizer!
-- notation `cend` := category_theory.End

-/

lemma Ext_compute_with_acyclic_naturality (C₁ C₂ : cochain_complex 𝓐 ℤ)
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₁).is_bounded_above]
  [((quotient 𝓐 (complex_shape.up ℤ)).obj C₂).is_bounded_above]
  (B : 𝓐)
  (hC₁ : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C₁.X k)).obj B))
  (hC₂ : ∀ k, ∀ i > 0, is_zero (((Ext' i).obj (op $ C₂.X k)).obj B))
  (f : C₁ ⟶ C₂)
  (i : ℤ) :
  ((Ext i).flip.obj ((single _ 0).obj B)).map (quiver.hom.op $ of'_hom f) ≫
    (Ext_compute_with_acyclic C₁ B hC₁ i).hom =
  (Ext_compute_with_acyclic C₂ B hC₂ i).hom ≫
    (((preadditive_yoneda.obj B).right_op.map_homological_complex _ ⋙
      homological_complex.unop_functor.right_op ⋙
      (_root_.homology_functor _ _ (-i)).op).map f).unop :=
begin
  dsimp only [Ext_compute_with_acyclic, iso.trans_hom],
  slice_lhs 1 2
  { erw Ext_compute_with_acyclic_aux₁_naturality },
  slice_lhs 2 3
  { rw Ext_compute_with_acyclic_aux₂_naturality },
  simp only [category.assoc],
  congr' 2,
  dsimp only [iso.symm_hom, as_iso_inv],
  rw [is_iso.eq_inv_comp, ← category.assoc, is_iso.comp_inv_eq],
  symmetry,
  apply Ext_compute_with_acyclic_aux₃_naturality,
end


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import logic.equiv.transfer_instance

/-!
# If `C` is preadditive, `Cᵒᵖ` has a natural preadditive structure.

-/

open opposite

namespace category_theory

variables (C : Type*) [category C] [preadditive C]

instance : preadditive Cᵒᵖ :=
{ hom_group := λ X Y, equiv.add_comm_group (op_equiv X Y),
  add_comp' := λ X Y Z f f' g,
    congr_arg quiver.hom.op (preadditive.comp_add _ _ _ g.unop f.unop f'.unop),
  comp_add' := λ X Y Z f g g',
    congr_arg quiver.hom.op (preadditive.add_comp _ _ _ g.unop g'.unop f.unop), }

instance module_End_left {X : Cᵒᵖ} {Y : C} : module (End X) (unop X ⟶ Y) :=
{ smul_add := λ r f g, preadditive.comp_add _ _ _ _ _ _,
  smul_zero := λ r, limits.comp_zero,
  add_smul := λ r s f, preadditive.add_comp _ _ _ _ _ _,
  zero_smul := λ f, limits.zero_comp }

@[simp] lemma unop_zero (X Y : Cᵒᵖ) : (0 : X ⟶ Y).unop = 0 := rfl
@[simp] lemma unop_add {X Y : Cᵒᵖ} (f g : X ⟶ Y) : (f + g).unop = f.unop + g.unop := rfl
@[simp] lemma op_zero (X Y : C) : (0 : X ⟶ Y).op = 0 := rfl
@[simp] lemma op_add {X Y : C} (f g : X ⟶ Y) : (f + g).op = f.op + g.op := rfl

variables {C} {D : Type*} [category D] [preadditive D]

instance functor.op_additive (F : C ⥤ D) [F.additive] : F.op.additive := {}

instance functor.right_op_additive (F : Cᵒᵖ ⥤ D) [F.additive] : F.right_op.additive := {}

instance functor.left_op_additive (F : C ⥤ Dᵒᵖ) [F.additive] : F.left_op.additive := {}

instance functor.unop_additive (F : Cᵒᵖ ⥤ Dᵒᵖ) [F.additive] : F.unop.additive := {}

end category_theory


/-
File: signature_recover_public_key_call_recover_public_key_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_recover_public_key_soundness
open tactic

open starkware.cairo.common.cairo_secp.verification.signature_recover_public_key
open starkware.cairo.common.cairo_secp.signature
open starkware.cairo.common.math
open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.cairo_secp.ec
open starkware.cairo.common.cairo_secp.bigint

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

/- starkware.cairo.common.cairo_secp.verification.signature_recover_public_key.call_recover_public_key autogenerated soundness theorem -/

theorem auto_sound_call_recover_public_key
    -- arguments
    (range_check_ptr : F) (msg_hash r s : BigInt3 F) (v : F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_call_recover_public_key σ.pc)
    -- all dependencies are in memory
    (h_mem_0 : mem_at mem code_assert_nn (σ.pc  - 903))
    (h_mem_1 : mem_at mem code_assert_le (σ.pc  - 899))
    (h_mem_2 : mem_at mem code_assert_nn_le (σ.pc  - 894))
    (h_mem_3 : mem_at mem code_bigint_mul (σ.pc  - 885))
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 871))
    (h_mem_5 : mem_at mem code_unreduced_mul (σ.pc  - 859))
    (h_mem_6 : mem_at mem code_unreduced_sqr (σ.pc  - 839))
    (h_mem_7 : mem_at mem code_verify_zero (σ.pc  - 823))
    (h_mem_8 : mem_at mem code_is_zero (σ.pc  - 800))
    (h_mem_9 : mem_at mem code_reduce (σ.pc  - 764))
    (h_mem_10 : mem_at mem code_validate_reduced_field_element (σ.pc  - 751))
    (h_mem_11 : mem_at mem code_ec_negate (σ.pc  - 711))
    (h_mem_12 : mem_at mem code_compute_doubling_slope (σ.pc  - 695))
    (h_mem_13 : mem_at mem code_compute_slope (σ.pc  - 651))
    (h_mem_14 : mem_at mem code_ec_double (σ.pc  - 627))
    (h_mem_15 : mem_at mem code_fast_ec_add (σ.pc  - 554))
    (h_mem_16 : mem_at mem code_ec_add (σ.pc  - 467))
    (h_mem_17 : mem_at mem code_ec_mul_inner (σ.pc  - 411))
    (h_mem_18 : mem_at mem code_ec_mul (σ.pc  - 310))
    (h_mem_19 : mem_at mem code_get_generator_point (σ.pc  - 230))
    (h_mem_20 : mem_at mem code_div_mod_n (σ.pc  - 217))
    (h_mem_21 : mem_at mem code_get_point_from_x (σ.pc  - 152))
    (h_mem_22 : mem_at mem code_recover_public_key (σ.pc  - 86))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 13))
    (hin_msg_hash : msg_hash = cast_BigInt3 mem (σ.fp - 12))
    (hin_r : r = cast_BigInt3 mem (σ.fp - 9))
    (hin_s : s = cast_BigInt3 mem (σ.fp - 6))
    (hin_v : v = mem (σ.fp - 3))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 13)) (mem $ τ.ap - 7)
        (spec_call_recover_public_key mem κ range_check_ptr msg_hash r s v (mem (τ.ap - 7)) (cast_EcPoint mem (τ.ap - 6)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_call_recover_public_key at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13⟩,
  -- tail function call
  step_assert_eq hpc0 with arg0,
  step_assert_eq hpc1 with arg1,
  step_assert_eq hpc2 with arg2,
  step_assert_eq hpc3 with arg3,
  step_assert_eq hpc4 with arg4,
  step_assert_eq hpc5 with arg5,
  step_assert_eq hpc6 with arg6,
  step_assert_eq hpc7 with arg7,
  step_assert_eq hpc8 with arg8,
  step_assert_eq hpc9 with arg9,
  step_assert_eq hpc10 with arg10,
  step_sub hpc11 (auto_sound_recover_public_key mem _ range_check_ptr msg_hash r s v _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _),
  { rw hpc12, norm_num2, exact h_mem_22 },
  { rw hpc12, norm_num2, exact h_mem_0 },
  { rw hpc12, norm_num2, exact h_mem_1 },
  { rw hpc12, norm_num2, exact h_mem_2 },
  { rw hpc12, norm_num2, exact h_mem_3 },
  { rw hpc12, norm_num2, exact h_mem_4 },
  { rw hpc12, norm_num2, exact h_mem_5 },
  { rw hpc12, norm_num2, exact h_mem_6 },
  { rw hpc12, norm_num2, exact h_mem_7 },
  { rw hpc12, norm_num2, exact h_mem_8 },
  { rw hpc12, norm_num2, exact h_mem_9 },
  { rw hpc12, norm_num2, exact h_mem_10 },
  { rw hpc12, norm_num2, exact h_mem_11 },
  { rw hpc12, norm_num2, exact h_mem_12 },
  { rw hpc12, norm_num2, exact h_mem_13 },
  { rw hpc12, norm_num2, exact h_mem_14 },
  { rw hpc12, norm_num2, exact h_mem_15 },
  { rw hpc12, norm_num2, exact h_mem_16 },
  { rw hpc12, norm_num2, exact h_mem_17 },
  { rw hpc12, norm_num2, exact h_mem_18 },
  { rw hpc12, norm_num2, exact h_mem_19 },
  { rw hpc12, norm_num2, exact h_mem_20 },
  { rw hpc12, norm_num2, exact h_mem_21 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_msg_hash, hin_r, hin_s, hin_v] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_msg_hash, hin_r, hin_s, hin_v] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_msg_hash, hin_r, hin_s, hin_v] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_msg_hash, hin_r, hin_s, hin_v] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_msg_hash, hin_r, hin_s, hin_v] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call13 ap13 h_call13,
  rcases h_call13 with ⟨rc_m13, rc_mle13, hl_range_check_ptr₁, h_call13⟩,
  step_ret hpc13,
  generalize' hr_rev_range_check_ptr₁: mem (ap13 - 7) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6 ,arg7 ,arg8 ,arg9 ,arg10] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6 ,arg7 ,arg8 ,arg9 ,arg10] at h_call13 },
  rw [hin_range_check_ptr] at h_call13,
  clear arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10,
  -- finish
  step_done, use_only [rfl, rfl],
  -- range check condition
  use_only (rc_m13+0+0), split,
  linarith [rc_mle13],
  split,
  { arith_simps,
    rw [←htv_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_call_recover_public_key mem _ range_check_ptr msg_hash r s v _ _,
  { apply sound_call_recover_public_key, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_call_recover_public_key],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call13],
  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 spec13 := h_call13 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr] at spec13,
  try { dsimp at spec13, arith_simps at spec13 },
  use_only [spec13],
  try { linarith },
end


-- Copyright (c) Microsoft Corporation. All rights reserved.
-- Licensed under the MIT license.

import ..smtexpr
import ..smtcompile
import ..bitvector
import .spec
import .lemmas_basic
import tactic.interactive

namespace spec

open smt
open irsem
open spec

-- unfold
meta def unfold_ops: tactic unit :=
  `[ try { unfold has_eq.eq },
     try { unfold has_comp.eq },
     try { unfold has_ne.ne },
     try { unfold has_comp.ne },
     try { unfold has_and.and },
     try { unfold has_ult.ult },
     try { unfold has_comp.ult },
     try { unfold has_ule.ule },
     try { unfold has_comp.ule },
     try { unfold has_ugt.ugt },
     try { unfold has_comp.ult },
     try { unfold has_uge.uge },
     try { unfold has_comp.ule },
     try { unfold has_slt.slt },
     try { unfold has_comp.slt },
     try { unfold has_sle.sle },
     try { unfold has_comp.sle },
     try { unfold has_sgt.sgt },
     try { unfold has_comp.slt },
     try { unfold has_sge.sge },
     try { unfold has_comp.sle } ]

meta def unfold_lops_at_all: tactic unit :=
  `[ try { unfold has_eq.eq at * },
     try { unfold has_comp.eq at * },
     try { unfold has_ne.ne at * },
     try { unfold has_comp.ne at * },
     try { unfold has_and.and at * },
     try { unfold has_or.or at * } ]

-- Constant sbitvec is never optimized.
lemma sbitvec_cons_notoptimized: ∀ sz z,
optimize_add_zero (sbitvec.const sz z) = (sbitvec.const sz z) :=
begin
  intros sz z,
  unfold optimize_add_zero
end

-- bitvector eq

lemma bveq: ∀ {sz:size} {b1 b2:bitvector sz},
  bitvector.eq b1 b2 = tt ↔ b1 = b2
:= begin
  intros,
  split,
  {
    intros H,
    cases b1, cases b2,
    unfold bitvector.eq at H,
    simp at H,
    assumption
  },{
    intros H,
    rw H, unfold bitvector.eq, simp
  }
end

lemma bvneq: ∀ (sz:size) (b1 b2:bitvector sz),
  bitvector.eq b1 b2 = ff ↔ b1 ≠ b2
:= begin
  intros sz b1 b2,
  split,
  { -- →
    intros H,
    cases b1,
    cases b2,
    unfold bitvector.eq at H,
    simp at H,
    apply H
  }, { -- ←
    intros H,
    cases b1,
    cases b2,
    unfold bitvector.eq,
    simp,
    apply H
  }
end

lemma bvneq_l : ∀ {sz:size} {b1 b2:bitvector sz},
  bitvector.eq b1 b2 = ff → b1 ≠ b2
:= begin intros, rw ← bvneq, assumption end

lemma bvneq_r : ∀ {sz:size} {b1 b2:bitvector sz},
  b1 ≠ b2 → bitvector.eq b1 b2 = ff
:= begin intros, rw bvneq, assumption end

lemma bvneq_from_z: ∀ (sz:size) (n m:int),
  n ≠ m → 0 ≤ n ∧ n < int.of_nat (2^sz.val)
        ∧ 0 ≤ m ∧ m < int.of_nat (2^sz.val) →
  bitvector.eq (uint_like.from_z sz n)
               (uint_like.from_z sz m) = ff
:= begin
  intros sz n m H H1,
  cases H1 with H1 H2,
  cases H2 with H2 H3,
  cases H3 with H3 H4,
  unfold uint_like.from_z,
  cases n; cases m,
  {
    unfold bitvector.of_int,
    unfold bitvector.eq,
    simp,
    intros H0,
    injection H0,
    have Hz := int.coe_nat_lt_coe_nat_iff,
    unfold_coes at Hz,
    rw Hz at H2,
    rw Hz at H4,
    rw nat.mod_eq_of_lt at h_1; try { assumption },
    rw nat.mod_eq_of_lt at h_1; try { assumption },
    apply H, congr, assumption,
  },
  { cases H3 },
  { cases H1 },
  { cases H3 }
end

lemma bvult_mod_sz: ∀ (sz:size) (eb:bitvector sz),
  bitvector.ult (eb%u uint_like.from_z sz ↑sz)
                (bitvector.of_int sz (int.of_nat (sz.val))) = tt
:= begin
  intros,
  cases sz, unfold_coes, unfold uint_like.from_z, unfold bitvector.ult,
  unfold bitvector.of_int, cases eb, simp, unfold has_umod.umod,
  unfold uint_like.urem, unfold bitvector.urem, unfold_coes, simp,
  rw nat.mod_pow2, rw nat.mod_eq_of_lt,
  {
    apply nat.mod_lt, assumption,
  },
  {
    apply lt_trans,
    { apply nat.mod_lt, assumption },
    apply nat.lt_pow2
  }
end

-- Lemmas regarding bvequiv

lemma bvequiv_of_int: ∀ sz x,
  bv_equiv (sbitvec.of_int sz x) (bitvector.of_int sz x)
:= begin
  intros,
  cases x; unfold sbitvec.of_int,
  { unfold bitvector.of_int,
    apply bv_equiv.const },
  {
    unfold bitvector.of_int,
    apply bv_equiv.const
  }
end

lemma bvequiv_from_z: ∀ (sz:size) n,
  bv_equiv (uint_like.from_z sz n)
           (uint_like.from_z sz n)
:= begin
  intros,
  unfold uint_like.from_z, apply bvequiv_of_int
end

lemma bvequiv_urem: ∀ (sz:size) (sb:sbitvec sz) eb
    (HA:bv_equiv sb eb),
  bv_equiv (sb%u uint_like.from_z sz sz.val)
           (eb%u uint_like.from_z sz sz.val)
:= begin
  intros,
  apply bv_equiv.urem, assumption, apply bvequiv_from_z,
  { cases sz, unfold_coes, simp, unfold uint_like.from_z, unfold bitvector.ne,
    unfold bitvector.of_int, simp,
    intros H, injection H, simp at h_1, rw nat.mod_pow2 at h_1,
    rw h_1 at sz_property, cases sz_property
  },
end

lemma bvequiv_never_var: ∀ sz s b,
  ¬ bv_equiv (sbitvec.var sz s) b
:= begin
  intros,intro H, cases H
end

lemma sbitvec_of_int_const: ∀ sz (b:bitvector sz),
  sbitvec.of_int sz (bitvector.to_int b) = sbitvec.const sz b
:= begin
  intros,
  cases b with b Hb,
  cases sz with sz Hsz,
  unfold_coes at *,
  unfold bitvector.to_int,
  simp,
  simp at Hb,
  have Hlt: decidable (b < 2^(sz - 1)), apply_instance,
  cases Hlt,
  {
    rw if_neg,
    unfold sbitvec.of_int,
    simp at *,
    have Hb' := nat.succ_le_of_lt Hb,
    have Hb'' := nat.sub_le_sub_right Hb' b,
    rw nat.succ_sub at Hb'',
    rw nat.sub_self at Hb'',
    generalize Hsz:2^sz - b = g,
    rw Hsz at *,
    rw nat.sub_sub,
    have Hg' : g - 1 + 1 = g,
    { rw nat.sub_add_cancel, apply Hb'' },
    rw Hg', rw ← Hsz,
    rw nat.sub_sub_self,
    rw nat.mod_eq_of_lt,
    assumption, apply le_of_lt, assumption, constructor, assumption
  },
  {
    rw if_pos,
    unfold_coes,
    unfold sbitvec.of_int,
    simp,
    rw nat.mod_eq_of_lt, assumption, assumption
  }
end

/-
 - Theorems about overflow.
 -/

lemma add_overflow_chk: ∀ (sz:size) isnsw (sa sb:sbitvec sz) (ea:bitvector sz) eb,
  bv_equiv sa ea → bv_equiv sb eb →
  b_equiv (sbitvec.overflow_chk @sbitvec.add size.one isnsw sa sb)
          (bitvector.add_overflows isnsw ea eb)
:= sorry

lemma sub_overflow_chk: ∀ (sz:size) isnsw (sa sb:sbitvec sz) (ea:bitvector sz) eb,
  bv_equiv sa ea → bv_equiv sb eb →
  b_equiv (sbitvec.overflow_chk @sbitvec.sub size.one isnsw sa sb)
          (bitvector.sub_overflows isnsw ea eb)
:= sorry

lemma mul_overflow_chk: ∀ (sz:size) isnsw (sa sb:sbitvec sz) (ea:bitvector sz) eb,
  bv_equiv sa ea → bv_equiv sb eb →
  b_equiv (sbitvec.overflow_chk @sbitvec.mul sz isnsw sa sb)
          (bitvector.mul_overflows isnsw ea eb)
:= sorry

lemma shl_overflow_chk: ∀ (sz:size) isnsw (sa sb:sbitvec sz) (ea:bitvector sz) eb,
  bv_equiv sa ea → bv_equiv sb eb →
  b_equiv (sbitvec.shl_overflow_chk sz isnsw sa sb)
          (bitvector.shl_overflows isnsw ea eb)
:= sorry

lemma to_bool_prop: ∀ p {dp:decidable p}, @to_bool p dp = tt → p
:= begin
  intros,
  cases dp,
  unfold to_bool at a, injection a
end

-- Same to poisonty_and_tt, but in the future poison may not be boolty.
lemma boolty_and_tt: ∀ (x:irsem_exec.boolty),
    bool_like.and tt x = x
:= begin intros, cases x;
  { delta bool_like.and, rw bool_is_bool_like, simp }
end

lemma boolty_or_tt2_op: ∀ (x:irsem_exec.boolty),
    x |b tt = tt
:= begin intros, cases x; refl end

lemma boolty_or_inj: ∀ {x y:irsem_exec.boolty}
    (H:bool_like.or x y = tt),
  x = tt ∨ y = tt
:= begin intros, cases x; cases y,
  cases H,
  any_goals { right, refl },
  any_goals { left, refl }
end

lemma boolty_and_inj: ∀ {x y:irsem_exec.boolty}
    (H:bool_like.and x y = tt),
  x = tt ∧ y = tt
:= begin intros, cases x; cases y; cases H, split; simp end

@[simp]
lemma b2p_id_exec: ∀ (b:irsem_exec.boolty),
  b2p irsem_exec b = b
:= begin intros, cases b; refl end

lemma b_equiv_ite: ∀ (sb:irsem_smt.boolty) b
    (H:b_equiv sb b),
  b_equiv ((has_ite.ite sb (bool_like.tt irsem_smt.poisonty)
        (bool_like.ff irsem_smt.poisonty)):irsem_smt.poisonty) b
:= begin
  intros,
  have HB: (b = cond b tt ff), cases b; simp,
  rw HB, apply b_equiv.ite, assumption, constructor, constructor
end

lemma b_equiv_and_tt: ∀ (s1 s2:irsem_smt.boolty) b
    (H:b_equiv s1 b)
    (H':b_equiv s2 tt),
  b_equiv (bool_like.and s1 s2) b
:= begin
  intros,
  have HB: (b = band b tt),
  { cases b, simp, simp },
  rw HB, apply b_equiv.and1, assumption,
  intros H2, apply H'
end

lemma b_equiv_and_ff: ∀ (s1 s2:irsem_smt.boolty)
    (H:b_equiv s1 ff),
  b_equiv (bool_like.and s1 s2) ff
:= begin
  intros,
  have Hb': ∃ b', band ff b' = ff,
  { apply exists.intro tt, refl },
  cases Hb' with b' Hb',
  rw ← Hb',
  have Hff:(ff = bool_like.and ff b'),
  { cases b', refl, refl },
  rw Hff, apply b_equiv.and1, assumption,
  intros H0, rw ← Hff at H0, cases H0
end

lemma b_equiv_and_ff2: ∀ (s1 s2:irsem_smt.boolty)
    (H:b_equiv s2 ff),
  b_equiv (bool_like.and s1 s2) ff
:= begin
  intros,
  have Hb': ∃ b', band b' ff = ff,
  { apply exists.intro tt, refl },
  cases Hb' with b' Hb',
  rw ← Hb',
  have Hff:(ff = bool_like.and b' ff),
  { cases b', refl, refl },
  rw Hff, apply b_equiv.and2, rw ← Hff, apply H,
  intros H0, rw ← Hff at H0, cases H0
end

lemma b_equiv_and: ∀ (s1 s2:irsem_smt.boolty) (b1 b2:irsem_exec.boolty)
    (H1: b_equiv s1 b1) (H2:b_equiv s2 b2),
  b_equiv (bool_like.and s1 s2) (bool_like.and b1 b2)
:= begin
  intros,
  apply b_equiv.and1,
  assumption, cases b1, intros H, cases H, intros H, assumption
end

lemma b_equiv_or: ∀ (s1 s2:irsem_smt.boolty) (b1 b2:irsem_exec.boolty)
    (H1: b_equiv s1 b1) (H2:b_equiv s2 b2),
  b_equiv (bool_like.or s1 s2) (bool_like.or b1 b2)
:= begin
  intros,
  apply b_equiv.or1,
  assumption, cases b1, intros H, assumption, intros H, cases H
end

lemma b_equiv_never_var: ∀ s b,
  ¬ b_equiv (sbool.var s) b
:= begin
  intros,intro H, cases H
end

@[simp]
lemma poisonty_tt: irsem_exec.pbl.tt = tt
:= begin refl end

@[simp]
lemma poisonty_ff: irsem_exec.pbl.ff = ff
:= begin refl end

@[simp]
lemma poisonty_and_tt: ∀ (x:irsem_exec.poisonty),
    bool_like.and tt x = x
:= begin intros, cases x;
  { delta bool_like.and, rw bool_is_bool_like, simp }
end

lemma poisonty_and_tt_op: ∀ (x:irsem_exec.poisonty),
    tt & x = x
:= begin intros, apply poisonty_and_tt end

@[simp]
lemma poisonty_and_tt2: ∀ (x:irsem_exec.poisonty),
    bool_like.and x tt = x
:= begin intros, cases x;
  { delta bool_like.and, rw irsem_exec.pbl, rw bool_is_bool_like, simp }
end

lemma poisonty_and_tt2_op: ∀ (x:irsem_exec.poisonty),
    x & tt = x
:= begin intros, apply poisonty_and_tt2 end

lemma poisonty_and_ff: ∀ (x:irsem_exec.poisonty),
    bool_like.and ff x = ff
:= begin intros, cases x;
  { delta bool_like.and, rw bool_is_bool_like, simp }
end

lemma poisonty_and_ff_op: ∀ (x:irsem_exec.poisonty),
    ff&x = ff
:= begin intros, unfold has_and.and, apply poisonty_and_ff end

lemma poisonty_and_ff2: ∀ (x:irsem_exec.poisonty),
    bool_like.and x ff = ff
:= begin intros, cases x;
  { delta bool_like.and, rw irsem_exec.pbl, rw bool_is_bool_like, simp }
end

lemma poisonty_and_ff2_op: ∀ (x:irsem_exec.poisonty),
    x & ff = ff
:= begin intros, unfold has_and.and, apply poisonty_and_ff2 end

lemma poisonty_and_inj: ∀ {x y:irsem_exec.poisonty}
    (H:bool_like.and x y = tt),
  x = tt ∧ y = tt
:= begin intros, cases x; cases y; cases H, split; simp end

lemma poisonty_or_ff: ∀ (x:irsem_exec.poisonty),
    bool_like.or ff x = x
:= begin intros, cases x; refl end

lemma poisonty_or_ff_op: ∀ (x:irsem_exec.poisonty),
    ff |b x = x
:= begin intros, apply poisonty_or_ff end

lemma poisonty_or_inj: ∀ {x y:irsem_exec.poisonty}
    (H:bool_like.or x y = tt),
  x = tt ∨ y = tt
:= begin intros, cases x; cases y,
  cases H,
  any_goals { right, refl },
  any_goals { left, refl }
end

lemma poison_equiv_and: forall (sx:irsem_smt.poisonty) sy
    (x:irsem_exec.poisonty) y
    (HXEQ:poison_equiv sx x)
    (HYEQ:poison_equiv sy y),
  poison_equiv (bool_like.and sx sy) (bool_like.and x y)
:= begin
  intros,
  cases HXEQ,
  cases HYEQ,
  constructor,
  apply b_equiv_and; assumption
end

lemma poison_equiv_ite: forall (sc:irsem_smt.boolty) (sx sy:irsem_smt.poisonty)
    (c:irsem_exec.boolty) (x y:irsem_exec.poisonty)
    (HCEQ:b_equiv sc c)
    (HXEQ:poison_equiv sx x)
    (HYEQ:poison_equiv sy y),
  poison_equiv (has_ite.ite sc sx sy) (has_ite.ite c x y)
:= begin
  intros,
  cases HXEQ,
  cases HYEQ,
  constructor,
  apply b_equiv.ite; assumption
end

lemma poison_equiv_and_ff: ∀ (s1 s2:irsem_smt.poisonty)
    (H:poison_equiv s1 ff),
  poison_equiv (bool_like.and s1 s2) ff
:= begin
  intros,
  cases H, constructor, apply b_equiv_and_ff, assumption
end

lemma poison_equiv_and_ff2: ∀ (s1 s2:irsem_smt.poisonty)
    (H:poison_equiv s2 ff),
  poison_equiv (bool_like.and s1 s2) ff
:= begin
  intros,
  cases H, constructor, apply b_equiv_and_ff2, assumption
end

lemma bop_poison_peel: ∀ {sz} {bopc} {flags} {ea} {eb}
    (H:bop_poison_all irsem_exec sz bopc flags ea eb = tt),
  bop_poison irsem_exec sz bopc ea eb = tt
:= begin
  unfold bop_poison_all,
  intros,
  induction flags,
  { -- when flags = []
    simp at H, assumption },
  { -- when flags = flags_hd::flags_tl
    simp at H,
    have H':= boolty_and_inj H,
    cases H', -- split ∧
    have ANSW := flags_ih H'_left,
    apply ANSW
  }
end

-- Lemmas about vppair

lemma val_equiv_eqsize: ∀ {sza szb:size}
    {a:sbitvec sza} {ap:poisonty_smt} {b bp},
  val_equiv (valty.ival sza a ap) (valty.ival szb b bp) →
  sza = szb
:= begin
  intros,
  rename a_1 H,
  cases H,
  { -- If val_equiv.poison
    assumption },
  { -- If val_equiv.concrete
    refl }
end

lemma val_equiv_eqpoison: ∀ (sza szb:size)
    (a:sbitvec sza) (ap:poisonty_smt) b bp,
  val_equiv (valty.ival sza a ap) (valty.ival szb b bp) →
  poison_equiv ap bp
:= begin
  intros,
  rename a_1 H,
  cases H; assumption
end

set_option pp.proofs true

lemma bv_equiv_cast: ∀ {sz sz':size} (sb:sbitvec sz) (bv:bitvector sz) H0 H1
    (H:bv_equiv sb bv)
    (HSZ:sz = sz'),
  @bv_equiv sz' (cast H0 sb) (cast H1 bv)
:= begin
  intros,
  induction HSZ,
  rw cast_eq,
  rw cast_eq,
  assumption
end

lemma valty_rwsize_smt: ∀ (sza szb:size) (a:irsem_smt.intty sza)
    (HSZEQ:sza = szb),
  valty.ival sza a = valty.ival szb (cast (by abstract eqH { rw HSZEQ }) a)
:= begin
  intros,
  congr,
  assumption,
  induction (valty_rwsize_smt.eqH sza szb HSZEQ),
  rw cast_eq
end

lemma valty_rwsize_exec: ∀ (sza szb:size) {a:irsem_exec.intty sza}
    (HSZEQ:sza = szb) {ap},
  valty.ival sza a ap = valty.ival szb (cast (by abstract eqH { rw HSZEQ }) a) ap
:= begin
  intros,
  congr,
  assumption,
  induction (valty_rwsize_exec.eqH sza szb HSZEQ),
  rw cast_eq
end

lemma sb_rwsize: ∀ (sza szb:size) (a:sbitvec sza)
    (HSZEQ:sza = szb),
  a = (cast (by abstract eqH {rw HSZEQ} ) a)
:= begin
  intros, rw cast_eq end

lemma bv_rwsize: ∀ (sza szb:size) (a:bitvector sza)
    (HSZEQ:sza = szb),
  a = (cast (by abstract eqH {rw HSZEQ} ) a)
:= begin
  intros, rw cast_eq end

lemma val_equiv_rwsize1: ∀ (sza sza' szb szb':size)
    (a:irsem_smt.intty sza) (b:irsem_exec.intty szb) ap bp
    (HSZEQ:sza = szb)
    (H:val_equiv (valty.ival sza a ap)
      (valty.ival sza (cast (by abstract eqH { rw HSZEQ }) b) bp)),
  val_equiv (valty.ival sza a ap) (valty.ival szb b bp)
:= begin
  intros,
  have H0: valty_rwsize_exec.eqH szb sza (eq.symm HSZEQ) =
          val_equiv_rwsize1.eqH sza szb HSZEQ, refl,
  rw ← H0 at H,
  rw ← valty_rwsize_exec at H,
  assumption
end

lemma val_equiv_rwsize2: ∀ (sza sza' szb szb':size)
    (a:irsem_smt.intty sza) (b:irsem_exec.intty szb) ap bp
    (HSZEQ1:sza = sza') (HSZEQ2:szb = szb')
    (H:val_equiv (valty.ival sza (cast (by rw HSZEQ1) a) ap)
      (valty.ival szb' (cast (by abstract eqH2 { rw HSZEQ2 }) b) bp)),
  val_equiv (valty.ival sza a ap) (valty.ival szb b bp)
:= begin
  intros,
  rw cast_eq at H,
  have H0: valty_rwsize_exec.eqH szb szb' HSZEQ2 =
          val_equiv_rwsize2.eqH2 szb szb' HSZEQ2, refl,
  rw ← H0 at H,
  rw ← valty_rwsize_exec at H,
  assumption
end

lemma val_equiv_rwsize1': ∀ (sza szb:size)
    (a:irsem_smt.intty sza) (b:irsem_exec.intty szb) ap bp
    (HSZEQ:sza = szb)
    (H:val_equiv (valty.ival sza a ap) (valty.ival szb b bp)),
  val_equiv (valty.ival sza a ap)
      (valty.ival sza (cast (by abstract eqH {rw HSZEQ}) b) bp)
:= begin
  intros,
  have H0: valty_rwsize_exec.eqH szb sza (eq.symm HSZEQ) =
          val_equiv_rwsize1'.eqH sza szb HSZEQ, refl,
  rw ← H0,
  rw ← valty_rwsize_exec,
  assumption
end

lemma val_equiv_rwsize2': ∀ (sza sza' szb szb':size)
    (a:irsem_smt.intty sza) (b:irsem_exec.intty szb) ap bp
    (HSZEQ1:sza = sza') (HSZEQ2:szb = szb')
    (H:val_equiv (valty.ival sza a ap) (valty.ival szb b bp)),
  val_equiv (valty.ival sza' (cast (by abstract eqH1 { rw HSZEQ1 }) a) ap)
      (valty.ival szb' (cast (by abstract eqH2 { rw HSZEQ2 }) b) bp)
:= begin
  intros,
  have H0: valty_rwsize_exec.eqH szb szb' HSZEQ2 =
          val_equiv_rwsize2'.eqH2 szb szb' HSZEQ2, refl,
  have H1: valty_rwsize_smt.eqH sza sza' HSZEQ1 =
          val_equiv_rwsize2'.eqH1 sza sza' HSZEQ1, refl,
  rw ← H0,
  rw ← H1,
  rw ← valty_rwsize_exec,
  rw ← valty_rwsize_smt,
  assumption
end

lemma poison_bool_equiv: ∀ ap bp,
  poison_equiv ap bp ↔ b_equiv ap bp
:= begin
  intros,
  split,
  { intros H, cases H, assumption },
  { intros H, constructor, assumption }
end

lemma none_or_some_implies: ∀ {α β:Type} a b
    (P1 P2:α → β → Prop)
    (HP: ∀ a b, P1 a b → P2 a b)
    (H:none_or_some a b P1),
  none_or_some a b P2
:= begin
  intros,
  unfold none_or_some at *,
  cases a; cases b,
  { left, split; refl },
  {
    cases H,
    cases H, cases H_right,
    cases H, cases H_h, cases H_h_h, cases H_h_h_left
  },
  {
    cases H,
    cases H, cases H_left,
    cases H, cases H_h, cases H_h_h, cases H_h_h_right,
    cases H_h_h_right_left
  },
  {
    cases H,
    left, apply H,
    right, cases H, cases H_h,
    apply exists.intro H_w,
    apply exists.intro H_h_w,
    cases H_h_h with H1 H2,
    cases H2 with H2 H3,
    split, assumption,
    split, assumption, apply HP, assumption
  }
end

universe u
lemma none_or_some_apply: ∀ {α β:Type} (a:α) (b:β) f, none_or_some (some a) (some b) f
  ↔ f a b
:= begin
  intros,
  unfold none_or_some,
  split,
  intros,
  cases a_1,
  cases a_1, cases a_1_left,
  cases a_1, cases a_1_h, cases a_1_h_h,
  cases a_1_h_h_left, cases a_1_h_h_right, cases a_1_h_h_right_left,
  assumption,
  intros,
  right, existsi a, existsi b, split, refl, split, refl, assumption
end

lemma none_or_some_none: ∀ {α β:Type} {a} {b}
    {P:α → β → Prop}
    (H:none_or_some a b P)
    (H1:a = none),
  b = none
:= begin
  intros,
  subst H1,
  unfold none_or_some at H,
  cases H,
  cases H, assumption,
  cases H, cases H_h, cases H_h_h, cases H_h_h_left
end

lemma none_or_some_none2: ∀ {α β:Type} {a} {b}
    {P:α → β → Prop}
    (H1:a = none) (H2:b = none),
  none_or_some a b P
:= begin
  intros,
  subst H1, subst H2,
  unfold none_or_some,
  left, split; refl
end

lemma none_or_some_some: ∀ {α β:Type} {a} {b} {a'}
    {P:α → β → Prop}
    (H:none_or_some a b P)
    (H1:a = some a'),
  ∃ b', b = some b'
:= begin
  intros,
  subst H1,
  unfold none_or_some at H,
  cases H,
  cases H, cases H_left,
  cases H, cases H_h, cases H_h_h, cases H_h_h_right,
  apply exists.intro H_h_w, assumption
end

lemma none_or_some_false1: ∀ {α β:Type} {a:α} {f}, ¬ none_or_some (some a) (@none β) f
:= begin
  intros,
  intros H,
  unfold none_or_some at H,
  cases H, cases H, cases H_left, cases H, cases H_h,
  cases H_h_h, cases H_h_h_right, cases H_h_h_right_left
end

lemma none_or_some_false2: ∀ {α β:Type} (a:α) f, ¬ none_or_some (@none β) (some a) f
:= begin
  intros,
  intros H,
  unfold none_or_some at H,
  cases H, cases H, cases H_right, cases H, cases H_h,
  cases H_h_h, cases H_h_h_left
end

end spec


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Control.ForInStep.Basic

/-! # Additional theorems on `ForInStep` -/

@[simp] theorem ForInStep.bind_done [Monad m] (a : α) (f : α → m (ForInStep α)) :
    (ForInStep.done a).bind (m := m) f = pure (.done a) := rfl
@[simp] theorem ForInStep.bind_yield [Monad m] (a : α) (f : α → m (ForInStep α)) :
    (ForInStep.yield a).bind (m := m) f = f a := rfl

attribute [simp] ForInStep.bindM

@[simp] theorem ForInStep.run_done : (ForInStep.done a).run = a := rfl
@[simp] theorem ForInStep.run_yield : (ForInStep.yield a).run = a := rfl

@[simp] theorem ForInStep.bindList_nil [Monad m] (f : α → β → m (ForInStep β))
    (s : ForInStep β) : s.bindList f [] = pure s := rfl

@[simp] theorem ForInStep.bindList_cons [Monad m]
    (f : α → β → m (ForInStep β)) (s : ForInStep β) (a l) :
    s.bindList f (a::l) = s.bind fun b => f a b >>= (·.bindList f l) := rfl

@[simp] theorem ForInStep.done_bindList [Monad m]
    (f : α → β → m (ForInStep β)) (a l) :
    (ForInStep.done a).bindList f l = pure (.done a) := by cases l <;> simp

@[simp] theorem ForInStep.bind_yield_bindList [Monad m]
    (f : α → β → m (ForInStep β)) (s : ForInStep β) (l) :
    (s.bind fun a => (yield a).bindList f l) = s.bindList f l := by cases s <;> simp

@[simp] theorem ForInStep.bind_bindList_assoc [Monad m] [LawfulMonad m]
    (f : β → m (ForInStep β)) (g : α → β → m (ForInStep β)) (s : ForInStep β) (l) :
    s.bind f >>= (·.bindList g l) = s.bind fun b => f b >>= (·.bindList g l)  := by
  cases s <;> simp

theorem ForInStep.bindList_cons' [Monad m] [LawfulMonad m]
    (f : α → β → m (ForInStep β)) (s : ForInStep β) (a l) :
    s.bindList f (a::l) = s.bind (f a) >>= (·.bindList f l) := by simp

@[simp] theorem ForInStep.bindList_append [Monad m] [LawfulMonad m]
    (f : α → β → m (ForInStep β)) (s : ForInStep β) (l₁ l₂) :
    s.bindList f (l₁ ++ l₂) = s.bindList f l₁ >>= (·.bindList f l₂) := by
  induction l₁ generalizing s <;> simp [*]