import category_theory.triangulated.rotate

namespace category_theory

namespace triangulated

open category_theory.triangulated.triangle_morphism

variables {C : Type*} [category C] [has_shift C ℤ] {T₁ T₂ : triangle C} (f : T₁ ⟶ T₂)

lemma triangle_morphism_is_iso [is_iso f.hom₁] [is_iso f.hom₂] [is_iso f.hom₃] :
  is_iso f :=
by { refine ⟨⟨⟨inv f.hom₁, inv f.hom₂, inv f.hom₃, _, _, _⟩, _, _⟩⟩; tidy }
.
instance [is_iso f] : is_iso f.hom₁ :=
by { refine ⟨⟨(inv f).hom₁, _, _⟩⟩; simpa only [← comp_hom₁, ← triangle_category_comp,
  is_iso.hom_inv_id, is_iso.inv_hom_id] }

instance [is_iso f] : is_iso f.hom₂ :=
by { refine ⟨⟨(inv f).hom₂, _, _⟩⟩; simpa only [← comp_hom₂, ← triangle_category_comp,
  is_iso.hom_inv_id, is_iso.inv_hom_id] }

instance [is_iso f] : is_iso f.hom₃ :=
by { refine ⟨⟨(inv f).hom₃, _, _⟩⟩; simpa only [← comp_hom₃, ← triangle_category_comp,
  is_iso.hom_inv_id, is_iso.inv_hom_id] }

@[simp] lemma inv_hom₁ [is_iso f] : (inv f).hom₁ = inv (f.hom₁) :=
by { ext, change (f ≫ inv f).hom₁ = _, rw is_iso.hom_inv_id, refl }

@[simp] lemma inv_hom₂ [is_iso f] : (inv f).hom₂ = inv (f.hom₂) :=
by { ext, change (f ≫ inv f).hom₂ = _, rw is_iso.hom_inv_id, refl }

@[simp] lemma inv_hom₃ [is_iso f] : (inv f).hom₃ = inv (f.hom₃) :=
by { ext, change (f ≫ inv f).hom₃ = _, rw is_iso.hom_inv_id, refl }

lemma triangle_morphism_is_iso_iff : is_iso f ↔
    is_iso f.hom₁ ∧ is_iso f.hom₂ ∧ is_iso f.hom₃ :=
begin
  split,
  { intro _, refine ⟨_, _, _⟩; exactI infer_instance },
  { rintro ⟨_, _, _⟩, exactI triangle_morphism_is_iso f }
end

@[simps]
def mk_triangle_iso (e₁ : T₁.obj₁ ≅ T₂.obj₁) (e₂ : T₁.obj₂ ≅ T₂.obj₂) (e₃ : T₁.obj₃ ≅ T₂.obj₃)
  (comm₁ : T₁.mor₁ ≫ e₂.hom = e₁.hom ≫ T₂.mor₁)
  (comm₂ : T₁.mor₂ ≫ e₃.hom = e₂.hom ≫ T₂.mor₂)
  (comm₃ : T₁.mor₃ ≫ e₁.hom⟦1⟧' = e₃.hom ≫ T₂.mor₃) : T₁ ≅ T₂ :=
⟨⟨_, _, _, comm₁, comm₂, comm₃⟩, ⟨e₁.inv, e₂.inv, e₃.inv,
  by { rw e₂.comp_inv_eq, simp [comm₁] }, by { rw e₃.comp_inv_eq, simp [comm₂] },
  by { rw [e₃.eq_inv_comp, ← category.assoc, ← comm₃], simp [← functor.map_comp] }⟩,
  by { ext; simp }, by { ext; simp }⟩

@[simps] noncomputable
def triangle.nonneg_inv_rotate (T : triangle C) : triangle C :=
triangle.mk _ (T.mor₃⟦(-1:ℤ)⟧' ≫ (shift_shift_neg _ _).hom) T.mor₁
  (T.mor₂ ≫ (shift_neg_shift _ _).inv)

@[simps]
def triangle.nonneg_rotate {C : Type*} [category C]
  [has_shift C ℤ] (T : triangle C) : triangle C := triangle.mk _ T.mor₂ T.mor₃ (T.mor₁⟦1⟧')

variables (C) [preadditive C]

@[simps]
def neg₃_functor : triangle C ⥤ triangle C :=
{ obj := λ T, triangle.mk C T.mor₁ T.mor₂ (-T.mor₃),
  map := λ S T f, { hom₁ := f.hom₁, hom₂ := f.hom₂, hom₃ := f.hom₃ } }

@[simps]
def neg₃_unit_iso : neg₃_functor C ⋙ neg₃_functor C ≅ 𝟭 _ :=
begin
  refine nat_iso.of_components
    (λ X, ⟨⟨𝟙 _, 𝟙 _, 𝟙 _, _, _, _⟩, ⟨𝟙 _, 𝟙 _, 𝟙 _, _, _, _⟩, _, _⟩) (λ X Y f, _),
  any_goals { ext },
  all_goals { dsimp,
    simp only [category.comp_id, category.id_comp, category_theory.functor.map_id, neg_neg] },
end

@[simps]
def neg₃_equiv : triangle C ≌ triangle C :=
{ functor := neg₃_functor C,
  inverse := neg₃_functor C,
  unit_iso := (neg₃_unit_iso C).symm,
  counit_iso := neg₃_unit_iso C }

--move this (do we want this?)
instance {C : Type*} [category C] [preadditive C] {X Y : C} : has_neg (X ≅ Y) :=
⟨λ e, ⟨-e.hom, -e.inv, by simp, by simp⟩⟩
.
@[simp] lemma neg_iso_hom {C : Type*} [category C] [preadditive C] {X Y : C} {e : X ≅ Y} :
  (-e).hom = -(e.hom) := rfl

@[simp] lemma neg_iso_inv {C : Type*} [category C] [preadditive C] {X Y : C} {e : X ≅ Y} :
  (-e).inv = -(e.inv) := rfl

--move this
@[simps]
def _root_.category_theory.equivalence.iso_equiv {C D : Type*} [category C] [category D]
  (e : C ≌ D) (X : C) (Y : D) : (e.functor.obj X ≅ Y) ≃ (X ≅ e.inverse.obj Y) :=
{ to_fun := λ f, e.unit_iso.app X ≪≫ e.inverse.map_iso f,
  inv_fun := λ f, e.functor.map_iso f ≪≫ e.counit_iso.app Y,
  left_inv := λ f, by { ext, dsimp, simp only [iso.inv_hom_id_app, category.assoc, functor.map_comp,
    e.fun_inv_map], rw reassoc_of e.functor_unit_iso_comp, dsimp, simp },
  right_inv := λ f, by { ext, dsimp, simp } }

variables {C} (T : triangle C)

noncomputable
def triangle.nonneg_inv_rotate_neg₃ [(shift_functor C (1 : ℤ)).additive] :
  (neg₃_functor C).obj T.nonneg_inv_rotate ≅ T.inv_rotate :=
begin
  fapply mk_triangle_iso,
  exact -iso.refl _,
  exact iso.refl _,
  exact iso.refl _,
  all_goals { dsimp, simp },
end

noncomputable
def triangle.nonneg_inv_rotate_iso [(shift_functor C (1 : ℤ)).additive] :
  T.nonneg_inv_rotate ≅ (neg₃_functor C).obj T.inv_rotate :=
(neg₃_equiv C).iso_equiv _ _ T.nonneg_inv_rotate_neg₃

@[simps]
def neg₃_rotate : neg₃_functor C ⋙ rotate C ≅ rotate C ⋙ neg₃_functor C :=
nat_iso.of_components
  (λ X, mk_triangle_iso (iso.refl _) (iso.refl _) (-iso.refl _)
    (by { dsimp, simp }) (by { dsimp, simp }) (by { dsimp, simp }))
  (λ X Y f, by { dsimp, ext; dsimp; simp })

lemma triangle.nonneg_rotate_neg₃ :
  (neg₃_functor C).obj T.nonneg_rotate = T.rotate := rfl

def triangle.nonneg_rotate_iso : T.nonneg_rotate ≅ (neg₃_functor C).obj T.rotate :=
(neg₃_equiv C).iso_equiv _ _ (iso.refl _)

--

@[simps]
def triangle.obj₁_functor : triangle C ⥤ C :=
{ obj := λ T, T.obj₁,
  map := λ S T f, f.hom₁,
  map_id' := λ _, rfl,
  map_comp' := λ A B C f g, rfl }

@[simps]
def triangle.obj₂_functor : triangle C ⥤ C :=
{ obj := λ T, T.obj₂,
  map := λ S T f, f.hom₂,
  map_id' := λ _, rfl,
  map_comp' := λ A B C f g, rfl }

@[simps]
def triangle.obj₃_functor : triangle C ⥤ C :=
{ obj := λ T, T.obj₃,
  map := λ S T f, f.hom₃,
  map_id' := λ _, rfl,
  map_comp' := λ A B C f g, rfl }

end triangulated

end category_theory


import category_theory.limits.preserves.limits
import category_theory.adjunction.evaluation
import algebra.group.ulift

import for_mathlib.ab4
import for_mathlib.AddCommGroup.exact
import for_mathlib.AddCommGroup.pt
import for_mathlib.AddCommGroup.ab4

import condensed.extr.equivalence

.

universe u

open category_theory
open category_theory.limits

instance : has_colimits (ExtrSheafProd.{u} Ab.{u+1}) :=
has_colimits_of_has_colimits_creates_colimits
(Condensed_ExtrSheafProd_equiv _).inverse

instance : has_limits (ExtrSheafProd.{u} Ab.{u+1}) :=
has_limits_of_has_limits_creates_limits
(Condensed_ExtrSheafProd_equiv _).inverse

instance : has_colimits_of_size.{u} Ab.{u+1} :=
has_colimits_of_size_shrink.{u u (u+1) (u+1)} Ab.{u+1}

open_locale classical

instance {C : Type (u+1)} [category.{u} C] : AB4 (C ⥤ Ab.{u+1}) :=
begin
  constructor,
  intros α X Y f hf,
  let t := _, change mono t,
  rw category_theory.nat_trans.mono_iff_app_mono,
  intros c,
  let eX : (∐ λ (a : α), X a).obj c ≅ (∐ λ (a : α), (X a).obj c) :=
    (is_colimit_of_preserves ((evaluation _ _).obj c)
      (colimit.is_colimit _)).cocone_point_unique_up_to_iso (colimit.is_colimit _)
    ≪≫ has_colimit.iso_of_nat_iso (discrete.nat_iso (λ _, iso.refl _)),
   let eY : (∐ λ (a : α), Y a).obj c ≅ (∐ λ (a : α), (Y a).obj c) :=
    (is_colimit_of_preserves ((evaluation _ _).obj c)
      (colimit.is_colimit _)).cocone_point_unique_up_to_iso (colimit.is_colimit _)
    ≪≫ has_colimit.iso_of_nat_iso (discrete.nat_iso (λ _, iso.refl _)),
  let tt : (∐ λ (a : α), (X a).obj c) ⟶ (∐ λ (a : α), (Y a).obj c) :=
    sigma.desc (λ a, (f a).app c ≫ sigma.ι _ a),
  haveI : mono tt,
  { dsimp [tt],
    apply AB4.cond, intros a, specialize hf a,
    rw category_theory.nat_trans.mono_iff_app_mono at hf,
    apply hf },
  suffices : t.app c = eX.hom ≫ tt ≫ eY.inv,
  { rw this, apply_instance },
  dsimp [eX, tt, t, eY],
  apply ((is_colimit_of_preserves ((evaluation _ _).obj c) (colimit.is_colimit _))).hom_ext,
  intros a,
  dsimp [is_colimit.cocone_point_unique_up_to_iso],
  simp only [category.assoc, ← nat_trans.comp_app, colimit.ι_desc],
  slice_rhs 0 1
  { erw ((is_colimit_of_preserves ((evaluation _ _).obj c) (colimit.is_colimit _))).fac },
  slice_rhs 0 1
  { erw colimit.ι_desc },
  dsimp,
  simp only [category.id_comp, colimit.ι_desc, cofan.mk_ι_app, category.assoc,
    has_colimit.iso_of_nat_iso_ι_inv, discrete.nat_iso_inv_app, functor.map_cocone_ι_app,
    colimit.cocone_ι, evaluation_obj_map],
  dsimp, simp, apply_instance
end

noncomputable
instance : creates_limits (ExtrSheafProd_to_presheaf.{u} Ab.{u+1}) :=
begin
  change creates_limits ((ExtrSheaf_ExtrSheafProd_equiv _).inverse ⋙
    Sheaf_to_presheaf _ _),
  apply_with category_theory.comp_creates_limits { instances := ff },
  apply_instance,
  exact @Sheaf.category_theory.Sheaf_to_presheaf.category_theory.creates_limits.{(u+2) u (u+1)}
    ExtrDisc.{u} _ ExtrDisc.proetale_topology Ab.{u+1} _ _,
end

instance : AB4 (ExtrSheafProd.{u} Ab.{u+1}) :=
AB4_of_preserves_colimits_of_reflects_limits_of_AB4
  (ExtrSheafProd_to_presheaf _)

-- TODO: Prove a lemma about transporting AB4 across an equivalence.
instance : AB4 (Condensed.{u} Ab.{u+1}) :=
AB4_of_preserves_colimits_of_reflects_limits_of_AB4
    (Condensed_ExtrSheafProd_equiv.{u} Ab.{u+1}).functor


import for_mathlib.derived.example
import breen_deligne.eval

noncomputable theory

open category_theory category_theory.preadditive

namespace breen_deligne
namespace package

variables (BD : package)
variables {𝒜 : Type*} [category 𝒜] [abelian 𝒜]
variables (F : 𝒜 ⥤ 𝒜)

def eval' : 𝒜 ⥤ cochain_complex 𝒜 ℤ :=
(data.eval_functor F).obj BD.data ⋙ homological_complex.embed complex_shape.embedding.nat_down_int_up

def eval : 𝒜 ⥤ bounded_homotopy_category 𝒜 :=
(data.eval_functor F).obj BD.data ⋙ chain_complex.to_bounded_homotopy_category

instance eval_additive : (BD.eval F).additive :=
functor.additive_of_map_fst_add_snd _ $ λ A,
begin
  refine homotopy_category.eq_of_homotopy _ _ _,
  rw [← functor.map_add],
  exact homological_complex.embed_homotopy _ _ (eval_functor_homotopy F BD A) _,
end

lemma eval_functor_obj_X (X : 𝒜) (n : ℕ) :
  (((data.eval_functor F).obj BD.data).obj X).X n = F.obj ((Pow (BD.data.X n)).obj X) := rfl

lemma eval_functor_obj_d (X : 𝒜) (m n : ℕ) :
  (((data.eval_functor F).obj BD.data).obj X).d m n =
    (universal_map.eval_Pow F (BD.data.d m n)).app X := rfl

lemma eval'_obj_X (X : 𝒜) (n : ℕ) :
  ((BD.eval' F).obj X).X (-n:ℤ) = F.obj ((Pow (BD.data.X n)).obj X) :=
by { cases n; apply eval_functor_obj_X }

lemma eval'_obj_X_0 (X : 𝒜) :
  ((BD.eval' F).obj X).X 0 = F.obj ((Pow (BD.data.X 0)).obj X) := rfl

lemma eval'_obj_X_succ (X : 𝒜) (n : ℕ) :
  ((BD.eval' F).obj X).X -[1+ n] = F.obj ((Pow (BD.data.X (n+1))).obj X) := rfl

lemma eval'_obj_d (X : 𝒜) (m n : ℕ) :
  ((BD.eval' F).obj X).d (-(m+1:ℕ):ℤ) (-(n+1:ℕ):ℤ) =
    (universal_map.eval_Pow F (BD.data.d (m+1) (n+1))).app X := rfl

lemma eval'_obj_d_0 (X : 𝒜) (n : ℕ) :
  ((BD.eval' F).obj X).d (-(n+1:ℕ):ℤ) (-(1:ℕ)+1:ℤ) =
    (universal_map.eval_Pow F (BD.data.d (n+1) 0)).app X := rfl

end package
end breen_deligne


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Data.Option.Basic

universe u v

theorem Option.eq_of_eq_some {α : Type u} : ∀ {x y : Option α}, (∀z, x = some z ↔ y = some z) → x = y
  | none,   none,   h => rfl
  | none,   some z, h => Option.noConfusion ((h z).2 rfl)
  | some z, none,   h => Option.noConfusion ((h z).1 rfl)
  | some z, some w, h => Option.noConfusion ((h w).2 rfl) (congrArg some)

theorem Option.eq_none_of_isNone {α : Type u} : ∀ {o : Option α}, o.isNone → o = none
  | none, h => rfl


/-
File: signature_recover_public_key_compute_doubling_slope_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_verify_zero_soundness
import .signature_recover_public_key_unreduced_sqr_soundness
import .signature_recover_public_key_unreduced_mul_soundness
import .signature_recover_public_key_nondet_bigint3_soundness
open tactic

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

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

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

theorem auto_sound_compute_doubling_slope
    -- arguments
    (range_check_ptr : F) (point : EcPoint F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_compute_doubling_slope σ.pc)
    -- all dependencies are in memory
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 176))
    (h_mem_5 : mem_at mem code_unreduced_mul (σ.pc  - 164))
    (h_mem_6 : mem_at mem code_unreduced_sqr (σ.pc  - 144))
    (h_mem_7 : mem_at mem code_verify_zero (σ.pc  - 128))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 9))
    (hin_point : point = cast_EcPoint mem (σ.fp - 8))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 85 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 9)) (mem $ τ.ap - 4)
        (spec_compute_doubling_slope mem κ range_check_ptr point (mem (τ.ap - 4)) (cast_BigInt3 mem (τ.ap - 3)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_compute_doubling_slope at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13, hpc14, hpc15, hpc16, hpc17, hpc18, hpc19, hpc20, hpc21, hpc22, hpc23, hpc24, hpc25, hpc26, hpc27, hpc28, hpc29, hpc30, hpc31, hpc32, hpc33, hpc34, hpc35, hpc36, hpc37, hpc38, hpc39, hpc40, hpc41, hpc42, hpc43⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_sub hpc1 (auto_sound_nondet_bigint3 mem _ range_check_ptr _ _),
  { rw hpc2, norm_num2, exact h_mem_4 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point] },
    try { dsimp [cast_EcPoint, cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call3 ap3 h_call3,
  rcases h_call3 with ⟨h_call3_ap_offset, h_call3⟩,
  rcases h_call3 with ⟨rc_m3, rc_mle3, hl_range_check_ptr₁, h_call3⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap3 - 4) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  generalize' hr_rev_slope: cast_BigInt3 mem (ap3 - 3) = slope,
  simp only [hr_rev_slope] at h_call3,
  have htv_slope := hr_rev_slope.symm, clear hr_rev_slope,
  try { simp only [arg0] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0] at h_call3 },
  rw [hin_range_check_ptr] at h_call3,
  clear arg0,
  -- function call
  step_assert_eq hpc3 with arg0,
  step_assert_eq hpc4 with arg1,
  step_assert_eq hpc5 with arg2,
  step_sub hpc6 (auto_sound_unreduced_sqr mem _ point.x _ _),
  { rw hpc7, norm_num2, exact h_mem_6 },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point, htv_range_check_ptr₁, htv_slope] },
      try { dsimp [cast_EcPoint, cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2] },
      try { simp only [h_call3_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call8 ap8 h_call8,
  rcases h_call8 with ⟨h_call8_ap_offset, h_call8⟩,
  generalize' hr_rev_x_sqr: cast_UnreducedBigInt3 mem (ap8 - 3) = x_sqr,
  simp only [hr_rev_x_sqr] at h_call8,
  have htv_x_sqr := hr_rev_x_sqr.symm, clear hr_rev_x_sqr,
  clear arg0 arg1 arg2,
  -- function call
  step_assert_eq hpc8 with arg0,
  step_assert_eq hpc9 with arg1,
  step_assert_eq hpc10 with arg2,
  step_assert_eq hpc11 with arg3,
  step_assert_eq hpc12 with arg4,
  step_assert_eq hpc13 with arg5,
  step_sub hpc14 (auto_sound_unreduced_mul mem _ slope point.y _ _ _),
  { rw hpc15, norm_num2, exact h_mem_5 },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point, htv_range_check_ptr₁, htv_slope, htv_x_sqr] },
      try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset, h_call8_ap_offset] },
      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_point, htv_range_check_ptr₁, htv_slope, htv_x_sqr] },
      try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset, h_call8_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call16 ap16 h_call16,
  rcases h_call16 with ⟨h_call16_ap_offset, h_call16⟩,
  generalize' hr_rev_slope_y: cast_UnreducedBigInt3 mem (ap16 - 3) = slope_y,
  simp only [hr_rev_slope_y] at h_call16,
  have htv_slope_y := hr_rev_slope_y.symm, clear hr_rev_slope_y,
  clear arg0 arg1 arg2 arg3 arg4 arg5,
  -- function call
  step_assert_eq hpc16 hpc17 with arg0,
  step_assert_eq hpc18 with arg1,
  step_assert_eq hpc19 hpc20 with arg2,
  step_assert_eq hpc21 with arg3,
  step_assert_eq hpc22 hpc23 with arg4,
  step_assert_eq hpc24 with arg5,
  step_assert_eq hpc25 hpc26 with arg6,
  step_assert_eq hpc27 with arg7,
  step_assert_eq hpc28 hpc29 with arg8,
  step_assert_eq hpc30 with arg9,
  step_assert_eq hpc31 hpc32 with arg10,
  step_assert_eq hpc33 with arg11,
  step_assert_eq hpc34 with arg12,
  step_assert_eq hpc35 with arg13,
  step_assert_eq hpc36 with arg14,
  step_assert_eq hpc37 with arg15,
  step_sub hpc38 (auto_sound_verify_zero mem _ range_check_ptr₁ {
    d0 := 3 * x_sqr.d0 - 2 * slope_y.d0,
    d1 := 3 * x_sqr.d1 - 2 * slope_y.d1,
    d2 := 3 * x_sqr.d2 - 2 * slope_y.d2
  } _ _ _),
  { rw hpc39, norm_num2, exact h_mem_7 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point, htv_range_check_ptr₁, htv_slope, htv_x_sqr, htv_slope_y] },
    try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, (eq_sub_of_eq_add arg13), (eq_sub_of_eq_add arg14), (eq_sub_of_eq_add arg15)] },
    try { simp only [h_call3_ap_offset, h_call8_ap_offset, h_call16_ap_offset] },
    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_point, htv_range_check_ptr₁, htv_slope, htv_x_sqr, htv_slope_y] },
      try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10, arg11, arg12, (eq_sub_of_eq_add arg13), (eq_sub_of_eq_add arg14), (eq_sub_of_eq_add arg15)] },
      try { simp only [h_call3_ap_offset, h_call8_ap_offset, h_call16_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call40 ap40 h_call40,
  rcases h_call40 with ⟨h_call40_ap_offset, h_call40⟩,
  rcases h_call40 with ⟨rc_m40, rc_mle40, hl_range_check_ptr₂, h_call40⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap40 - 1) = range_check_ptr₂,
  have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6 ,arg7 ,arg8 ,arg9 ,arg10 ,arg11 ,arg12 ,arg13 ,arg14 ,arg15] at hl_range_check_ptr₂ },
  try { rw [h_call16_ap_offset, h_call8_ap_offset] at hl_range_check_ptr₂ }, try { arith_simps at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0 ,arg1 ,arg2 ,arg3 ,arg4 ,arg5 ,arg6 ,arg7 ,arg8 ,arg9 ,arg10 ,arg11 ,arg12 ,arg13 ,arg14 ,arg15] at h_call40 },
  try { rw [h_call16_ap_offset, h_call8_ap_offset] at h_call40 }, try { arith_simps at h_call40 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call40,
  clear arg0 arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15,
  -- return
  step_assert_eq hpc40 with hret0,
  step_assert_eq hpc41 with hret1,
  step_assert_eq hpc42 with hret2,
  step_ret hpc43,
  -- finish
  step_done, use_only [rfl, rfl],
  split,
  { try { simp only [h_call3_ap_offset ,h_call8_ap_offset ,h_call16_ap_offset ,h_call40_ap_offset] },
    try { arith_simps }, try { refl } },
  -- range check condition
  use_only (rc_m3+rc_m40+0+0), split,
  linarith [rc_mle3, rc_mle40],
  split,
  { arith_simps, try { simp only [hret0 ,hret1 ,hret2] },
    rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_compute_doubling_slope mem _ range_check_ptr point _ _,
  { apply sound_compute_doubling_slope, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_compute_doubling_slope],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call3],
  use_only [range_check_ptr₁],
  use_only [slope],
  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 spec3 := h_call3 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec3,
  try { dsimp at spec3, arith_simps at spec3 },
  use_only [spec3],
  use_only [κ_call8],
  use_only [x_sqr],
  try { dsimp at h_call8, arith_simps at h_call8 },
  try { use_only [h_call8] },
  use_only [κ_call16],
  use_only [slope_y],
  try { dsimp at h_call16, arith_simps at h_call16 },
  try { use_only [h_call16] },
  use_only [κ_call40],
  use_only [range_check_ptr₂],
  have rc_h_range_check_ptr₂ := range_checked_offset' rc_h_range_check_ptr₁,
  have rc_h_range_check_ptr₂' := range_checked_add_right rc_h_range_check_ptr₂, try { norm_cast at rc_h_range_check_ptr₂' },
  have spec40 := h_call40 rc_h_range_check_ptr₁',
  rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec40,
  try { dsimp at spec40, arith_simps at spec40 },
  use_only [spec40],
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_point, htv_range_check_ptr₁, htv_slope, htv_x_sqr, htv_slope_y, htv_range_check_ptr₂] }, },
  try { dsimp [cast_EcPoint, cast_BigInt3, cast_UnreducedBigInt3] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2] },
  try { simp only [h_call3_ap_offset, h_call8_ap_offset, h_call16_ap_offset, h_call40_ap_offset] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura

Various multiplicative and additive structures.
-/
import tactic.interactive data.option

section pending_1857

/- Transport multiplicative to additive -/
section transport
open tactic

@[user_attribute]
meta def to_additive_attr : user_attribute (name_map name) name :=
{ name      := `to_additive,
  descr     := "Transport multiplicative to additive",
  cache_cfg := ⟨λ ns, ns.mfoldl (λ dict n, do
    val ← to_additive_attr.get_param n,
    pure $ dict.insert n val) mk_name_map, []⟩,
  parser    := lean.parser.ident,
  after_set := some $ λ src _ _, do
    env ← get_env,
    dict ← to_additive_attr.get_cache,
    tgt ← to_additive_attr.get_param src,
    (get_decl tgt >> skip) <|>
      transport_with_dict dict src tgt }

end transport

/- map operations -/
attribute [to_additive has_add.add] has_mul.mul
attribute [to_additive has_zero.zero] has_one.one
attribute [to_additive has_neg.neg] has_inv.inv
attribute [to_additive has_add] has_mul
attribute [to_additive has_zero] has_one
attribute [to_additive has_neg] has_inv

/- map constructors -/
attribute [to_additive has_add.mk] has_mul.mk
attribute [to_additive has_zero.mk] has_one.mk
attribute [to_additive has_neg.mk] has_inv.mk

/- map structures -/
attribute [to_additive add_semigroup] semigroup
attribute [to_additive add_semigroup.mk] semigroup.mk
attribute [to_additive add_semigroup.to_has_add] semigroup.to_has_mul
attribute [to_additive add_semigroup.add_assoc] semigroup.mul_assoc
attribute [to_additive add_semigroup.add] semigroup.mul

attribute [to_additive add_comm_semigroup] comm_semigroup
attribute [to_additive add_comm_semigroup.mk] comm_semigroup.mk
attribute [to_additive add_comm_semigroup.to_add_semigroup] comm_semigroup.to_semigroup
attribute [to_additive add_comm_semigroup.add_comm] comm_semigroup.mul_comm

attribute [to_additive add_left_cancel_semigroup] left_cancel_semigroup
attribute [to_additive add_left_cancel_semigroup.mk] left_cancel_semigroup.mk
attribute [to_additive add_left_cancel_semigroup.to_add_semigroup] left_cancel_semigroup.to_semigroup
attribute [to_additive add_left_cancel_semigroup.add_left_cancel] left_cancel_semigroup.mul_left_cancel

attribute [to_additive add_right_cancel_semigroup] right_cancel_semigroup
attribute [to_additive add_right_cancel_semigroup.mk] right_cancel_semigroup.mk
attribute [to_additive add_right_cancel_semigroup.to_add_semigroup] right_cancel_semigroup.to_semigroup
attribute [to_additive add_right_cancel_semigroup.add_right_cancel] right_cancel_semigroup.mul_right_cancel

attribute [to_additive add_monoid] monoid
attribute [to_additive add_monoid.mk] monoid.mk
attribute [to_additive add_monoid.to_has_zero] monoid.to_has_one
attribute [to_additive add_monoid.to_add_semigroup] monoid.to_semigroup
attribute [to_additive add_monoid.add] monoid.mul
attribute [to_additive add_monoid.add_assoc] monoid.mul_assoc
attribute [to_additive add_monoid.zero] monoid.one
attribute [to_additive add_monoid.zero_add] monoid.one_mul
attribute [to_additive add_monoid.add_zero] monoid.mul_one

attribute [to_additive add_comm_monoid] comm_monoid
attribute [to_additive add_comm_monoid.mk] comm_monoid.mk
attribute [to_additive add_comm_monoid.to_add_monoid] comm_monoid.to_monoid
attribute [to_additive add_comm_monoid.to_add_comm_semigroup] comm_monoid.to_comm_semigroup

attribute [to_additive add_group] group
attribute [to_additive add_group.mk] group.mk
attribute [to_additive add_group.to_has_neg] group.to_has_inv
attribute [to_additive add_group.to_add_monoid] group.to_monoid
attribute [to_additive add_group.add_left_neg] group.mul_left_inv
attribute [to_additive add_group.add] group.mul
attribute [to_additive add_group.add_assoc] group.mul_assoc
attribute [to_additive add_group.zero] group.one
attribute [to_additive add_group.zero_add] group.one_mul
attribute [to_additive add_group.add_zero] group.mul_one
attribute [to_additive add_group.neg] group.inv

attribute [to_additive add_comm_group] comm_group
attribute [to_additive add_comm_group.mk] comm_group.mk
attribute [to_additive add_comm_group.to_add_group] comm_group.to_group
attribute [to_additive add_comm_group.to_add_comm_monoid] comm_group.to_comm_monoid

/- map theorems -/
attribute [to_additive add_assoc] mul_assoc
attribute [to_additive add_semigroup_to_is_associative] semigroup_to_is_associative
attribute [to_additive add_comm] mul_comm
attribute [to_additive add_comm_semigroup_to_is_commutative] comm_semigroup_to_is_commutative
attribute [to_additive add_left_comm] mul_left_comm
attribute [to_additive add_right_comm] mul_right_comm
attribute [to_additive add_left_cancel] mul_left_cancel
attribute [to_additive add_right_cancel] mul_right_cancel
attribute [to_additive add_left_cancel_iff] mul_left_cancel_iff
attribute [to_additive add_right_cancel_iff] mul_right_cancel_iff
attribute [to_additive zero_add] one_mul
attribute [to_additive add_zero] mul_one
attribute [to_additive add_left_neg] mul_left_inv
attribute [to_additive neg_add_self] inv_mul_self
attribute [to_additive neg_add_cancel_left] inv_mul_cancel_left
attribute [to_additive neg_add_cancel_right] inv_mul_cancel_right
attribute [to_additive neg_eq_of_add_eq_zero] inv_eq_of_mul_eq_one
attribute [to_additive neg_zero] one_inv
attribute [to_additive neg_neg] inv_inv
attribute [to_additive add_right_neg] mul_right_inv
attribute [to_additive add_neg_self] mul_inv_self
attribute [to_additive neg_inj] inv_inj
attribute [to_additive add_group.add_left_cancel] group.mul_left_cancel
attribute [to_additive add_group.add_right_cancel] group.mul_right_cancel
attribute [to_additive add_group.to_left_cancel_add_semigroup] group.to_left_cancel_semigroup
attribute [to_additive add_group.to_right_cancel_add_semigroup] group.to_right_cancel_semigroup
attribute [to_additive add_neg_cancel_left] mul_inv_cancel_left
attribute [to_additive add_neg_cancel_right] mul_inv_cancel_right
attribute [to_additive neg_add_rev] mul_inv_rev
attribute [to_additive eq_neg_of_eq_neg] eq_inv_of_eq_inv
attribute [to_additive eq_neg_of_add_eq_zero] eq_inv_of_mul_eq_one
attribute [to_additive eq_add_neg_of_add_eq] eq_mul_inv_of_mul_eq
attribute [to_additive eq_neg_add_of_add_eq] eq_inv_mul_of_mul_eq
attribute [to_additive neg_add_eq_of_eq_add] inv_mul_eq_of_eq_mul
attribute [to_additive add_neg_eq_of_eq_add] mul_inv_eq_of_eq_mul
attribute [to_additive eq_add_of_add_neg_eq] eq_mul_of_mul_inv_eq
attribute [to_additive eq_add_of_neg_add_eq] eq_mul_of_inv_mul_eq
attribute [to_additive add_eq_of_eq_neg_add] mul_eq_of_eq_inv_mul
attribute [to_additive add_eq_of_eq_add_neg] mul_eq_of_eq_mul_inv
attribute [to_additive neg_add] mul_inv

end pending_1857

universes u v
variables {α : Type u} {β : Type v}

def additive (α : Type*) := α
def multiplicative (α : Type*) := α

instance [semigroup α] : add_semigroup (additive α) :=
{ add := ((*) : α → α → α),
  add_assoc := @mul_assoc _ _ }

instance [add_semigroup α] : semigroup (multiplicative α) :=
{ mul := ((+) : α → α → α),
  mul_assoc := @add_assoc _ _ }

instance [comm_semigroup α] : add_comm_semigroup (additive α) :=
{ add_comm := @mul_comm _ _,
  ..additive.add_semigroup }

instance [add_comm_semigroup α] : comm_semigroup (multiplicative α) :=
{ mul_comm := @add_comm _ _,
  ..multiplicative.semigroup }

instance [left_cancel_semigroup α] : add_left_cancel_semigroup (additive α) :=
{ add_left_cancel := @mul_left_cancel _ _,
  ..additive.add_semigroup }

instance [add_left_cancel_semigroup α] : left_cancel_semigroup (multiplicative α) :=
{ mul_left_cancel := @add_left_cancel _ _,
  ..multiplicative.semigroup }

instance [right_cancel_semigroup α] : add_right_cancel_semigroup (additive α) :=
{ add_right_cancel := @mul_right_cancel _ _,
  ..additive.add_semigroup }

instance [add_right_cancel_semigroup α] : right_cancel_semigroup (multiplicative α) :=
{ mul_right_cancel := @add_right_cancel _ _,
  ..multiplicative.semigroup }

@[simp, to_additive add_left_inj]
theorem mul_left_inj [left_cancel_semigroup α] (a : α) {b c : α} : a * b = a * c ↔ b = c :=
⟨mul_left_cancel, congr_arg _⟩

@[simp, to_additive add_right_inj]
theorem mul_right_inj [right_cancel_semigroup α] (a : α) {b c : α} : b * a = c * a ↔ b = c :=
⟨mul_right_cancel, congr_arg _⟩

structure units (α : Type u) [monoid α] :=
(val : α)
(inv : α)
(val_inv : val * inv = 1)
(inv_val : inv * val = 1)

namespace units
variables [monoid α] {a b c : units α}

instance : has_coe (units α) α := ⟨val⟩

@[extensionality] theorem ext : ∀ {a b : units α}, (a : α) = b → a = b
| ⟨v, i₁, vi₁, iv₁⟩ ⟨v', i₂, vi₂, iv₂⟩ e :=
  by change v = v' at e; subst v'; congr;
      simpa [iv₂, vi₁] using mul_assoc i₂ v i₁

theorem ext_iff {a b : units α} : a = b ↔ (a : α) = b :=
⟨congr_arg _, ext⟩

instance [decidable_eq α] : decidable_eq (units α)
| a b := decidable_of_iff' _ ext_iff

protected def mul (u₁ u₂ : units α) : units α :=
⟨u₁.val * u₂.val, u₂.inv * u₁.inv,
  have u₁.val * (u₂.val * u₂.inv) * u₁.inv = 1,
    by rw [u₂.val_inv]; simp [u₁.val_inv],
  by simpa [mul_comm, mul_assoc],
  have u₂.inv * (u₁.inv * u₁.val) * u₂.val = 1,
    by rw [u₁.inv_val]; simp [u₂.inv_val],
  by simpa [mul_comm, mul_assoc]⟩

protected def inv' (u : units α) : units α :=
⟨u.inv, u.val, u.inv_val, u.val_inv⟩

instance : has_mul (units α) := ⟨units.mul⟩
instance : has_one (units α) := ⟨⟨1, 1, mul_one 1, one_mul 1⟩⟩
instance : has_inv (units α) := ⟨units.inv'⟩

variables (a b)
@[simp] lemma mul_coe : (↑(a * b) : α) = a * b := rfl
@[simp] lemma one_coe : ((1 : units α) : α) = 1 := rfl
lemma val_coe : (↑a : α) = a.val := rfl
lemma inv_coe : ((a⁻¹ : units α) : α) = a.inv := rfl
@[simp] lemma inv_mul : (↑a⁻¹ * a : α) = 1 := inv_val _
@[simp] lemma mul_inv : (a * ↑a⁻¹ : α) = 1 := val_inv _

@[simp] lemma mul_inv_cancel_left (a : units α) (b : α) : (a:α) * (↑a⁻¹ * b) = b :=
by rw [← mul_assoc, mul_inv, one_mul]

@[simp] lemma inv_mul_cancel_left (a : units α) (b : α) : (↑a⁻¹:α) * (a * b) = b :=
by rw [← mul_assoc, inv_mul, one_mul]

@[simp] lemma mul_inv_cancel_right (a : α) (b : units α) : a * b * ↑b⁻¹ = a :=
by rw [mul_assoc, mul_inv, mul_one]

@[simp] lemma inv_mul_cancel_right (a : α) (b : units α) : a * ↑b⁻¹ * b = a :=
by rw [mul_assoc, inv_mul, mul_one]

instance : group (units α) :=
by refine {mul := (*), one := 1, inv := has_inv.inv, ..};
  { intros, apply ext, simp [mul_assoc] }

instance {α} [comm_monoid α] : comm_group (units α) :=
{ mul_comm := λ u₁ u₂, ext $ mul_comm _ _, ..units.group }

instance [has_repr α] : has_repr (units α) := ⟨repr ∘ val⟩

@[simp] theorem mul_left_inj (a : units α) {b c : α} : (a:α) * b = a * c ↔ b = c :=
⟨λ h, by simpa using congr_arg ((*) ↑(a⁻¹ : units α)) h, congr_arg _⟩

@[simp] theorem mul_right_inj (a : units α) {b c : α} : b * a = c * a ↔ b = c :=
⟨λ h, by simpa using congr_arg (* ↑(a⁻¹ : units α)) h, congr_arg _⟩

end units

theorem nat.units_eq_one (u : units ℕ) : u = 1 :=
units.ext begin
  cases nat.eq_zero_or_pos u with h h,
  { simpa [h] using u.inv_mul },
  cases nat.eq_zero_or_pos ↑u⁻¹ with h' h',
  { simpa [h'] using u.inv_mul },
  refine le_antisymm _ h,
  simpa using nat.mul_le_mul_left u h'
end

def units.mk_of_mul_eq_one [comm_monoid α] (a b : α) (hab : a * b = 1) : units α :=
⟨a, b, hab, by rwa mul_comm a b at hab⟩

@[to_additive with_zero]
def with_one (α) := option α

@[to_additive with_zero.has_coe_t]
instance : has_coe_t α (with_one α) := ⟨some⟩

instance [semigroup α] : monoid (with_one α) :=
{ one       := none,
  mul       := option.lift_or_get (*),
  mul_assoc := (option.lift_or_get_assoc _).1,
  one_mul   := (option.lift_or_get_is_left_id _).1,
  mul_one   := (option.lift_or_get_is_right_id _).1 }

attribute [to_additive with_zero.add_monoid._proof_1] with_one.monoid._proof_1
attribute [to_additive with_zero.add_monoid._proof_2] with_one.monoid._proof_2
attribute [to_additive with_zero.add_monoid._proof_3] with_one.monoid._proof_3
attribute [to_additive with_zero.add_monoid] with_one.monoid

instance [semigroup α] : mul_zero_class (with_zero α) :=
{ zero      := none,
  mul       := λ o₁ o₂, o₁.bind (λ a, o₂.map (λ b, a * b)),
  zero_mul  := by simp,
  mul_zero  := λ a, by cases a; simp,
  ..with_zero.add_monoid }

instance [semigroup α] : semigroup (with_zero α) :=
{ mul_assoc := λ a b c, begin
    cases a with a, {refl},
    cases b with b, {refl},
    cases c with c, {refl},
    simp [mul_assoc]
  end,
  ..with_zero.mul_zero_class }

instance [comm_semigroup α] : comm_semigroup (with_zero α) :=
{ mul_comm := λ a b, begin
    cases a with a; cases b with b; try {refl},
    exact congr_arg some (mul_comm _ _)
  end,
  ..with_zero.semigroup }

instance [monoid α] : monoid (with_zero α) :=
{ one := some 1,
  one_mul := λ a, by cases a;
    [refl, exact congr_arg some (one_mul a)],
  mul_one := λ a, by cases a;
    [refl, exact congr_arg some (mul_one a)],
  ..with_zero.semigroup }

instance [comm_monoid α] : comm_monoid (with_zero α) :=
{ ..with_zero.monoid, ..with_zero.comm_semigroup }

instance [monoid α] : add_monoid (additive α) :=
{ zero     := (1 : α),
  zero_add := @one_mul _ _,
  add_zero := @mul_one _ _,
  ..additive.add_semigroup }

instance [add_monoid α] : monoid (multiplicative α) :=
{ one     := (0 : α),
  one_mul := @zero_add _ _,
  mul_one := @add_zero _ _,
  ..multiplicative.semigroup }

section monoid
  variables [monoid α] {a b c : α}

  /-- Partial division. It is defined when the
    second argument is invertible, and unlike the division operator
    in `division_ring` it is not totalized at zero. -/
  def divp (a : α) (u) : α := a * (u⁻¹ : units α)

  infix ` /ₚ `:70 := divp

  @[simp] theorem divp_self (u : units α) : (u : α) /ₚ u = 1 := by simp [divp]

  @[simp] theorem divp_one (a : α) : a /ₚ 1 = a := by simp [divp]

  theorem divp_assoc (a b : α) (u : units α) : a * b /ₚ u = a * (b /ₚ u) :=
  by simp [divp, mul_assoc]

  @[simp] theorem divp_mul_cancel (a : α) (u : units α) : a /ₚ u * u = a :=
  by simp [divp, mul_assoc]

  @[simp] theorem mul_divp_cancel (a : α) (u : units α) : (a * u) /ₚ u = a :=
  by simp [divp, mul_assoc]

  @[simp] theorem divp_right_inj (u : units α) {a b : α} : a /ₚ u = b /ₚ u ↔ a = b :=
  units.mul_right_inj _

  theorem divp_eq_one (a : α) (u : units α) : a /ₚ u = 1 ↔ a = u :=
  (units.mul_right_inj u).symm.trans $ by simp

  @[simp] theorem one_divp (u : units α) : 1 /ₚ u = ↑u⁻¹ :=
  by simp [divp]

end monoid

instance [comm_semigroup α] : comm_monoid (with_one α) :=
{ mul_comm := (option.lift_or_get_comm _).1,
  ..with_one.monoid }

instance [add_comm_semigroup α] : add_comm_monoid (with_zero α) :=
{ add_comm := (option.lift_or_get_comm _).1,
  ..with_zero.add_monoid }
attribute [to_additive with_zero.add_comm_monoid] with_one.comm_monoid

instance [comm_monoid α] : add_comm_monoid (additive α) :=
{ add_comm := @mul_comm α _,
  ..additive.add_monoid }

instance [add_comm_monoid α] : comm_monoid (multiplicative α) :=
{ mul_comm := @add_comm α _,
  ..multiplicative.monoid }

instance [group α] : add_group (additive α) :=
{ neg := @has_inv.inv α _,
  add_left_neg := @mul_left_inv _ _,
  ..additive.add_monoid }

instance [add_group α] : group (multiplicative α) :=
{ inv := @has_neg.neg α _,
  mul_left_inv := @add_left_neg _ _,
  ..multiplicative.monoid }

section group
  variables [group α] {a b c : α}

  instance : has_lift α (units α) :=
  ⟨λ a, ⟨a, a⁻¹, mul_inv_self _, inv_mul_self _⟩⟩

  @[simp, to_additive neg_inj']
  theorem inv_inj' : a⁻¹ = b⁻¹ ↔ a = b :=
  ⟨λ h, by rw ← inv_inv a; simp [h], congr_arg _⟩

  @[to_additive eq_of_neg_eq_neg]
  theorem eq_of_inv_eq_inv : a⁻¹ = b⁻¹ → a = b :=
  inv_inj'.1

  @[simp, to_additive add_self_iff_eq_zero]
  theorem mul_self_iff_eq_one : a * a = a ↔ a = 1 :=
  by have := @mul_left_inj _ _ a a 1; rwa mul_one at this

  @[simp, to_additive neg_eq_zero]
  theorem inv_eq_one : a⁻¹ = 1 ↔ a = 1 :=
  by rw [← @inv_inj' _ _ a 1, one_inv]

  @[simp, to_additive neg_ne_zero]
  theorem inv_ne_one : a⁻¹ ≠ 1 ↔ a ≠ 1 :=
  not_congr inv_eq_one

  @[to_additive left_inverse_neg]
  theorem left_inverse_inv (α) [group α] :
    function.left_inverse (λ a : α, a⁻¹) (λ a, a⁻¹) :=
  assume a, inv_inv a

  attribute [simp] mul_inv_cancel_left add_neg_cancel_left
                   mul_inv_cancel_right add_neg_cancel_right

  @[to_additive eq_neg_iff_eq_neg]
  theorem eq_inv_iff_eq_inv : a = b⁻¹ ↔ b = a⁻¹ :=
  ⟨eq_inv_of_eq_inv, eq_inv_of_eq_inv⟩

  @[to_additive neg_eq_iff_neg_eq]
  theorem inv_eq_iff_inv_eq : a⁻¹ = b ↔ b⁻¹ = a :=
  by rw [eq_comm, @eq_comm _ _ a, eq_inv_iff_eq_inv]

  @[to_additive add_eq_zero_iff_eq_neg]
  theorem mul_eq_one_iff_eq_inv : a * b = 1 ↔ a = b⁻¹ :=
  by simpa [mul_left_inv, -mul_right_inj] using @mul_right_inj _ _ b a (b⁻¹)

  @[to_additive add_eq_zero_iff_neg_eq]
  theorem mul_eq_one_iff_inv_eq : a * b = 1 ↔ a⁻¹ = b :=
  by rw [mul_eq_one_iff_eq_inv, eq_inv_iff_eq_inv, eq_comm]

  @[to_additive eq_neg_iff_add_eq_zero]
  theorem eq_inv_iff_mul_eq_one : a = b⁻¹ ↔ a * b = 1 :=
  mul_eq_one_iff_eq_inv.symm

  @[to_additive neg_eq_iff_add_eq_zero]
  theorem inv_eq_iff_mul_eq_one : a⁻¹ = b ↔ a * b = 1 :=
  mul_eq_one_iff_inv_eq.symm

  @[to_additive eq_add_neg_iff_add_eq]
  theorem eq_mul_inv_iff_mul_eq : a = b * c⁻¹ ↔ a * c = b :=
  ⟨λ h, by simp [h], λ h, by simp [h.symm]⟩

  @[to_additive eq_neg_add_iff_add_eq]
  theorem eq_inv_mul_iff_mul_eq : a = b⁻¹ * c ↔ b * a = c :=
  ⟨λ h, by simp [h], λ h, by simp [h.symm]⟩

  @[to_additive neg_add_eq_iff_eq_add]
  theorem inv_mul_eq_iff_eq_mul : a⁻¹ * b = c ↔ b = a * c :=
  ⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

  @[to_additive add_neg_eq_iff_eq_add]
  theorem mul_inv_eq_iff_eq_mul : a * b⁻¹ = c ↔ a = c * b :=
  ⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

  @[to_additive add_neg_eq_zero]
  theorem mul_inv_eq_one {a b : α} : a * b⁻¹ = 1 ↔ a = b :=
  by rw [mul_eq_one_iff_eq_inv, inv_inv]

  @[to_additive neg_comm_of_comm]
  theorem inv_comm_of_comm {a b : α} (H : a * b = b * a) : a⁻¹ * b = b * a⁻¹ :=
  begin
    have : a⁻¹ * (b * a) * a⁻¹ = a⁻¹ * (a * b) * a⁻¹ :=
      congr_arg (λ x:α, a⁻¹ * x * a⁻¹) H.symm,
    rwa [mul_assoc, mul_assoc, mul_inv_self, mul_one,
        ← mul_assoc, inv_mul_self, one_mul] at this; exact h
  end

end group

instance [comm_group α] : add_comm_group (additive α) :=
{ add_comm := @mul_comm α _,
  ..additive.add_group }

instance [add_comm_group α] : comm_group (multiplicative α) :=
{ mul_comm := @add_comm α _,
  ..multiplicative.group }

section add_monoid
  variables [add_monoid α] {a b c : α}

  @[simp] lemma bit0_zero : bit0 (0 : α) = 0 := add_zero _
  @[simp] lemma bit1_zero [has_one α] : bit1 (0 : α) = 1 := by simp [bit1]

end add_monoid

section add_group
  variables [add_group α] {a b c : α}

  local attribute [simp] sub_eq_add_neg

  def sub_sub_cancel := @sub_sub_self

  @[simp] lemma sub_left_inj : a - b = a - c ↔ b = c :=
  (add_left_inj _).trans neg_inj'

  @[simp] lemma sub_right_inj : b - a = c - a ↔ b = c :=
  add_right_inj _

  lemma sub_add_sub_cancel (a b c : α) : (a - b) + (b - c) = a - c :=
  by simp

  lemma sub_sub_sub_cancel_right (a b c : α) : (a - c) - (b - c) = a - b :=
  by simp

  theorem sub_eq_zero : a - b = 0 ↔ a = b :=
  ⟨eq_of_sub_eq_zero, λ h, by simp [h]⟩

  theorem sub_ne_zero : a - b ≠ 0 ↔ a ≠ b :=
  not_congr sub_eq_zero

  theorem eq_sub_iff_add_eq : a = b - c ↔ a + c = b :=
  by split; intro h; simp [h, eq_add_neg_iff_add_eq]

  theorem sub_eq_iff_eq_add : a - b = c ↔ a = c + b :=
  by split; intro h; simp [*, add_neg_eq_iff_eq_add] at *

  theorem eq_iff_eq_of_sub_eq_sub {a b c d : α} (H : a - b = c - d) : a = b ↔ c = d :=
  by rw [← sub_eq_zero, H, sub_eq_zero]

  theorem left_inverse_sub_add_left (c : α) : function.left_inverse (λ x, x - c) (λ x, x + c) :=
  assume x, add_sub_cancel x c

  theorem left_inverse_add_left_sub (c : α) : function.left_inverse (λ x, x + c) (λ x, x - c) :=
  assume x, sub_add_cancel x c

  theorem left_inverse_add_right_neg_add (c : α) :
      function.left_inverse (λ x, c + x) (λ x, - c + x) :=
  assume x, add_neg_cancel_left c x

  theorem left_inverse_neg_add_add_right (c : α) :
      function.left_inverse (λ x, - c + x) (λ x, c + x) :=
  assume x, neg_add_cancel_left c x
end add_group

section add_comm_group
  variables [add_comm_group α] {a b c : α}

  lemma sub_eq_neg_add (a b : α) : a - b = -b + a :=
  by simp

  theorem neg_add' (a b : α) : -(a + b) = -a - b := neg_add a b

  lemma eq_sub_iff_add_eq' : a = b - c ↔ c + a = b :=
  by rw [eq_sub_iff_add_eq, add_comm]

  lemma sub_eq_iff_eq_add' : a - b = c ↔ a = b + c :=
  by rw [sub_eq_iff_eq_add, add_comm]

  lemma add_sub_cancel' (a b : α) : a + b - a = b :=
  by simp

  lemma add_sub_cancel'_right (a b : α) : a + (b - a) = b :=
  by rw [← add_sub_assoc, add_sub_cancel']

  lemma sub_right_comm (a b c : α) : a - b - c = a - c - b :=
  by simp

  lemma sub_add_sub_cancel' (a b c : α) : (a - b) + (c - a) = c - b :=
  by rw add_comm; apply sub_add_sub_cancel

  lemma sub_sub_sub_cancel_left (a b c : α) : (c - a) - (c - b) = b - a :=
  by simp

end add_comm_group

section is_conj
variables [group α] [group β]

def is_conj (a b : α) := ∃ c : α, c * a * c⁻¹ = b

@[refl] lemma is_conj_refl (a : α) : is_conj a a := ⟨1, by simp⟩

@[symm] lemma is_conj_symm (a b : α) : is_conj a b → is_conj b a
| ⟨c, hc⟩ := ⟨c⁻¹, by simp [hc.symm, mul_assoc]⟩

@[trans] lemma is_conj_trans (a b c : α) : is_conj a b → is_conj b c → is_conj a c
| ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ := ⟨c₂ * c₁, by simp [hc₁.symm, hc₂.symm, mul_assoc]⟩

@[simp] lemma is_conj_iff_eq {α : Type*} [comm_group α] {a b : α} : is_conj a b ↔ a = b :=
⟨λ ⟨c, hc⟩, by rw [← hc, mul_right_comm, mul_inv_self, one_mul], λ h, by rw h⟩

end is_conj

class is_monoid_hom [monoid α] [monoid β] (f : α → β) : Prop :=
(map_one : f 1 = 1)
(map_mul : ∀ {x y}, f (x * y) = f x * f y)

class is_add_monoid_hom [add_monoid α] [add_monoid β] (f : α → β) : Prop :=
(map_zero : f 0 = 0)
(map_add : ∀ {x y}, f (x + y) = f x + f y)

attribute [to_additive is_add_monoid_hom] is_monoid_hom
attribute [to_additive is_add_monoid_hom.map_add] is_monoid_hom.map_mul
attribute [to_additive is_add_monoid_hom.mk] is_monoid_hom.mk

namespace is_monoid_hom
variables [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]

@[to_additive is_add_monoid_hom.id]
instance id : is_monoid_hom (@id α) := by refine {..}; intros; refl

@[to_additive is_add_monoid_hom.id]
instance comp {γ} [monoid γ] (g : β → γ) [is_monoid_hom g] :
  is_monoid_hom (g ∘ f) :=
{ map_mul := λ x y, by simp [map_mul f]; rw map_mul g; refl,
  map_one := by simp [map_one f]; exact map_one g }

end is_monoid_hom

-- TODO rename fields of is_group_hom: mul ↝ map_mul?

/-- Predicate for group homomorphism. -/
class is_group_hom [group α] [group β] (f : α → β) : Prop :=
(mul : ∀ a b : α, f (a * b) = f a * f b)

class is_add_group_hom [add_group α] [add_group β] (f : α → β) : Prop :=
(add : ∀ a b, f (a + b) = f a + f b)

attribute [to_additive is_add_group_hom] is_group_hom
attribute [to_additive is_add_group_hom.add] is_group_hom.mul
attribute [to_additive is_add_group_hom.mk] is_group_hom.mk

namespace is_group_hom
variables [group α] [group β] (f : α → β) [is_group_hom f]

@[to_additive is_add_group_hom.zero]
theorem one : f 1 = 1 :=
mul_self_iff_eq_one.1 $ by simp [(mul f 1 1).symm]

@[to_additive is_add_group_hom.neg]
theorem inv (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq.symm $ inv_eq_of_mul_eq_one $ by simp [(mul f a a⁻¹).symm, one f]

@[to_additive is_add_group_hom.id]
instance id : is_group_hom (@id α) :=
⟨λ _ _, rfl⟩

@[to_additive is_add_group_hom.comp]
instance comp {γ} [group γ] (g : β → γ) [is_group_hom g] :
  is_group_hom (g ∘ f) :=
⟨λ x y, calc
  g (f (x * y)) = g (f x * f y)       : by rw mul f
  ...           = g (f x) * g (f y)   : by rw mul g⟩

protected lemma is_conj (f : α → β) [is_group_hom f] {a b : α} : is_conj a b → is_conj (f a) (f b)
| ⟨c, hc⟩ := ⟨f c, by rw [← is_group_hom.mul f, ← is_group_hom.inv f, ← is_group_hom.mul f, hc]⟩

end is_group_hom

/-- Predicate for group anti-homomorphism, or a homomorphism
  into the opposite group. -/
class is_group_anti_hom {β : Type*} [group α] [group β] (f : α → β) : Prop :=
(mul : ∀ a b : α, f (a * b) = f b * f a)

namespace is_group_anti_hom
variables [group α] [group β] (f : α → β) [w : is_group_anti_hom f]
include w

theorem one : f 1 = 1 :=
mul_self_iff_eq_one.1 $ by simp [(mul f 1 1).symm]

theorem inv (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq.symm $ inv_eq_of_mul_eq_one $ by simp [(mul f a⁻¹ a).symm, one f]

end is_group_anti_hom

theorem inv_is_group_anti_hom [group α] : is_group_anti_hom (λ x : α, x⁻¹) :=
⟨mul_inv_rev⟩

namespace is_add_group_hom
variables [add_group α] [add_group β] (f : α → β) [is_add_group_hom f]

lemma sub (a b) : f (a - b) = f a - f b :=
calc f (a - b) = f (a + -b)   : rfl
           ... = f a + f (-b) : add f _ _
           ... = f a - f b    : by  simp[neg f]

end is_add_group_hom


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.category.Bipointed
import data.two_pointing

/-!
# The category of two-pointed types

This defines `Twop`, the category of two-pointed types.

## References

* [nLab, *coalgebra of the real interval*]
  (https://ncatlab.org/nlab/show/coalgebra+of+the+real+interval)
-/

open category_theory option

universes u
variables {α β : Type*}

/-- The category of two-pointed types. -/
structure Twop : Type.{u+1} :=
(X : Type.{u})
(to_two_pointing : two_pointing X)

namespace Twop

instance : has_coe_to_sort Twop Type* := ⟨X⟩

attribute [protected] Twop.X

/-- Turns a two-pointing into a two-pointed type. -/
def of {X : Type*} (to_two_pointing : two_pointing X) : Twop := ⟨X, to_two_pointing⟩

@[simp] lemma coe_of {X : Type*} (to_two_pointing : two_pointing X) :
  ↥(of to_two_pointing) = X := rfl

alias of ← two_pointing.Twop

instance : inhabited Twop := ⟨of two_pointing.bool⟩

/-- Turns a two-pointed type into a bipointed type, by forgetting that the pointed elements are
distinct. -/
def to_Bipointed (X : Twop) : Bipointed := X.to_two_pointing.to_prod.Bipointed

@[simp] lemma coe_to_Bipointed (X : Twop) : ↥X.to_Bipointed = ↥X := rfl

instance large_category : large_category Twop := induced_category.category to_Bipointed

instance concrete_category : concrete_category Twop :=
induced_category.concrete_category to_Bipointed

instance has_forget_to_Bipointed : has_forget₂ Twop Bipointed :=
induced_category.has_forget₂ to_Bipointed

/-- Swaps the pointed elements of a two-pointed type. `two_pointing.swap` as a functor. -/
@[simps] def swap : Twop ⥤ Twop :=
{ obj := λ X, ⟨X, X.to_two_pointing.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Twop` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Twop ≌ Twop :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Twop

@[simp] lemma Twop_swap_comp_forget_to_Bipointed :
  Twop.swap ⋙ forget₂ Twop Bipointed = forget₂ Twop Bipointed ⋙ Bipointed.swap := rfl

/-- The functor from `Pointed` to `Twop` which adds a second point. -/
@[simps] def Pointed_to_Twop_fst : Pointed.{u} ⥤ Twop :=
{ obj := λ X, ⟨option X, ⟨X.point, none⟩, some_ne_none _⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

/-- The functor from `Pointed` to `Twop` which adds a first point. -/
@[simps] def Pointed_to_Twop_snd : Pointed.{u} ⥤ Twop :=
{ obj := λ X, ⟨option X, ⟨none, X.point⟩, (some_ne_none _).symm⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Twop_fst_comp_swap :
  Pointed_to_Twop_fst ⋙ Twop.swap = Pointed_to_Twop_snd := rfl

@[simp] lemma Pointed_to_Twop_snd_comp_swap :
  Pointed_to_Twop_snd ⋙ Twop.swap = Pointed_to_Twop_fst := rfl

@[simp] lemma Pointed_to_Twop_fst_comp_forget_to_Bipointed :
  Pointed_to_Twop_fst ⋙ forget₂ Twop Bipointed = Pointed_to_Bipointed_fst := rfl

@[simp] lemma Pointed_to_Twop_snd_comp_forget_to_Bipointed :
  Pointed_to_Twop_snd ⋙ forget₂ Twop Bipointed = Pointed_to_Bipointed_snd := rfl

/-- Adding a second point is left adjoint to forgetting the second point. -/
def Pointed_to_Twop_fst_forget_comp_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Twop_fst ⊣ forget₂ Twop Bipointed ⋙ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
    inv_fun := λ f, ⟨λ o, o.elim Y.to_two_pointing.to_prod.2 f.to_fun, f.map_point, rfl⟩,
    left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
    right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- Adding a first point is left adjoint to forgetting the first point. -/
def Pointed_to_Twop_snd_forget_comp_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Twop_snd ⊣ forget₂ Twop Bipointed ⋙ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
    inv_fun := λ f, ⟨λ o, o.elim Y.to_two_pointing.to_prod.1 f.to_fun, rfl, f.map_point⟩,
    left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
    right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.functor.currying
import category_theory.limits.over
import category_theory.limits.shapes.images
import category_theory.adjunction.reflective

/-!
# Monomorphisms over a fixed object

As preparation for defining `subobject X`, we set up the theory for
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not yet a partial order.

`subobject X` will be defined as the skeletalization of `mono_over X`.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : mono_over Y ⥤ mono_over X`
* `def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : mono_over X ⥤ mono_over Y`
and prove their basic properties and relationships.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/--
The category of monomorphisms into `X` as a full subcategory of the over category.
This isn't skeletal, so it's not a partial order.

Later we define `subobject X` as the quotient of this by isomorphisms.
-/
@[derive [category]]
def mono_over (X : C) := {f : over X // mono f.hom}

namespace mono_over

/-- Construct a `mono_over X`. -/
@[simps]
def mk' {X A : C} (f : A ⟶ X) [hf : mono f] : mono_over X := { val := over.mk f, property := hf }

/-- The inclusion from monomorphisms over X to morphisms over X. -/
def forget (X : C) : mono_over X ⥤ over X := full_subcategory_inclusion _

instance : has_coe (mono_over X) C :=
{ coe := λ Y, Y.val.left, }

@[simp]
lemma forget_obj_left {f} : ((forget X).obj f).left = (f : C) := rfl

@[simp] lemma mk'_coe' {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f : C) = A := rfl

/-- Convenience notation for the underlying arrow of a monomorphism over X. -/
abbreviation arrow (f : mono_over X) : (f : C) ⟶ X := ((forget X).obj f).hom

@[simp] lemma mk'_arrow {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f).arrow = f := rfl

@[simp]
lemma forget_obj_hom {f} : ((forget X).obj f).hom = f.arrow := rfl

instance : full (forget X) := full_subcategory.full _
instance : faithful (forget X) := full_subcategory.faithful _

instance mono (f : mono_over X) : mono f.arrow := f.property

/-- The category of monomorphisms over X is a thin category,
which makes defining its skeleton easy. -/
instance is_thin {X : C} (f g : mono_over X) : subsingleton (f ⟶ g) :=
⟨begin
  intros h₁ h₂,
  ext1,
  erw [← cancel_mono g.arrow, over.w h₁, over.w h₂],
end⟩

@[reassoc] lemma w {f g : mono_over X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow := over.w _

/-- Convenience constructor for a morphism in monomorphisms over `X`. -/
abbreviation hom_mk {f g : mono_over X} (h : f.val.left ⟶ g.val.left) (w : h ≫ g.arrow = f.arrow) :
  f ⟶ g :=
over.hom_mk h w

/-- Convenience constructor for an isomorphism in monomorphisms over `X`. -/
@[simps]
def iso_mk {f g : mono_over X} (h : f.val.left ≅ g.val.left) (w : h.hom ≫ g.arrow = f.arrow) :
  f ≅ g :=
{ hom := hom_mk h.hom w,
  inv := hom_mk h.inv (by rw [h.inv_comp_eq, w]) }

/-- If `f : mono_over X`, then `mk' f.arrow` is of course just `f`, but not definitionally, so we
    package it as an isomorphism. -/
@[simp] def mk'_arrow_iso {X : C} (f : mono_over X) : (mk' f.arrow) ≅ f :=
iso_mk (iso.refl _) (by simp)

/--
Lift a functor between over categories to a functor between `mono_over` categories,
given suitable evidence that morphisms are taken to monomorphisms.
-/
@[simps]
def lift {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  mono_over Y ⥤ mono_over X :=
{ obj := λ f, ⟨_, h f⟩,
  map := λ _ _ k, (mono_over.forget X).preimage ((mono_over.forget Y ⋙ F).map k), }

/--
Isomorphic functors `over Y ⥤ over X` lift to isomorphic functors `mono_over Y ⥤ mono_over X`.
-/
def lift_iso {Y : D} {F₁ F₂ : over Y ⥤ over X} (h₁ h₂) (i : F₁ ≅ F₂) :
  lift F₁ h₁ ≅ lift F₂ h₂ :=
fully_faithful_cancel_right (mono_over.forget X) (iso_whisker_left (mono_over.forget Y) i)

/-- `mono_over.lift` commutes with composition of functors. -/
def lift_comp {X Z : C} {Y : D} (F : over X ⥤ over Y) (G : over Y ⥤ over Z) (h₁ h₂) :
  lift F h₁ ⋙ lift G h₂ ≅ lift (F ⋙ G) (λ f, h₂ ⟨_, h₁ f⟩) :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

/-- `mono_over.lift` preserves the identity functor. -/
def lift_id :
  lift (𝟭 (over X)) (λ f, f.2) ≅ 𝟭 _ :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

@[simp]
lemma lift_comm (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  lift F h ⋙ mono_over.forget X = mono_over.forget Y ⋙ F :=
rfl

@[simp]
lemma lift_obj_arrow {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) (f : mono_over Y) :
  ((lift F h).obj f).arrow = (F.obj ((forget Y).obj f)).hom :=
rfl

/--
Monomorphisms over an object `f : over A` in an over category
are equivalent to monomorphisms over the source of `f`.
-/
def slice {A : C} {f : over A} (h₁ h₂) : mono_over f ≌ mono_over f.left :=
{ functor := mono_over.lift f.iterated_slice_equiv.functor h₁,
  inverse := mono_over.lift f.iterated_slice_equiv.inverse h₂,
  unit_iso := mono_over.lift_id.symm ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.unit_iso ≪≫
    (mono_over.lift_comp _ _ _ _).symm,
  counit_iso := mono_over.lift_comp _ _ _ _ ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.counit_iso ≪≫
    mono_over.lift_id }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `mono_over Y ⥤ mono_over X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : mono_over Y ⥤ mono_over X :=
mono_over.lift (over.pullback f)
begin
  intro g,
  apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _,
  change mono g.arrow,
  apply_instance,
end

/-- pullback commutes with composition (up to a natural isomorphism) -/
def pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) : pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
lift_iso _ _ (over.pullback_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- pullback preserves the identity (up to a natural isomorphism) -/
def pullback_id : pullback (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.pullback_id ≪≫ lift_id

@[simp] lemma pullback_obj_left (f : X ⟶ Y) (g : mono_over Y) :
  (((pullback f).obj g) : C) = limits.pullback g.arrow f :=
rfl

@[simp] lemma pullback_obj_arrow (f : X ⟶ Y) (g : mono_over Y) :
  ((pullback f).obj g).arrow = pullback.snd :=
rfl

end pullback

section map

attribute [instance] mono_comp

/--
We can map monomorphisms over `X` to monomorphisms over `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y :=
lift (over.map f)
(λ g, by apply mono_comp g.arrow f)

/-- `mono_over.map` commutes with composition (up to a natural isomorphism). -/
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  map (f ≫ g) ≅ map f ⋙ map g :=
lift_iso _ _ (over.map_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- `mono_over.map` preserves the identity (up to a natural isomorphism). -/
def map_id : map (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.map_id ≪≫ lift_id

@[simp] lemma map_obj_left (f : X ⟶ Y) [mono f] (g : mono_over X) :
  (((map f).obj g) : C) = g.val.left :=
rfl

@[simp]
lemma map_obj_arrow (f : X ⟶ Y) [mono f] (g : mono_over X) :
  ((map f).obj g).arrow = g.arrow ≫ f :=
rfl

instance full_map (f : X ⟶ Y) [mono f] : full (map f) :=
{ preimage := λ g h e,
  begin
    refine hom_mk e.left _,
    rw [← cancel_mono f, assoc],
    apply w e,
  end }

instance faithful_map (f : X ⟶ Y) [mono f] : faithful (map f) := {}.

/--
Isomorphic objects have equivalent `mono_over` categories.
-/
@[simps] def map_iso {A B : C} (e : A ≅ B) : mono_over A ≌ mono_over B :=
{ functor := map e.hom,
  inverse := map e.inv,
  unit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id).symm,
  counit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id) }

section
variables (X)

/-- An equivalence of categories `e` between `C` and `D` induces an equivalence between
    `mono_over X` and `mono_over (e.functor.obj X)` whenever `X` is an object of `C`. -/
@[simps] def congr (e : C ≌ D) : mono_over X ≌ mono_over (e.functor.obj X) :=
{ functor := lift (over.post e.functor) $ λ f, by { dsimp, apply_instance },
  inverse := (lift (over.post e.inverse) $ λ f, by { dsimp, apply_instance })
    ⋙ (map_iso (e.unit_iso.symm.app X)).functor,
  unit_iso := nat_iso.of_components (λ Y, iso_mk (e.unit_iso.app Y) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ Y, iso_mk (e.counit_iso.app Y) (by tidy)) (by tidy) }

end

section
variable [has_pullbacks C]

/-- `map f` is left adjoint to `pullback f` when `f` is a monomorphism -/
def map_pullback_adj (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
adjunction.restrict_fully_faithful
  (forget X) (forget Y) (over.map_pullback_adj f) (iso.refl _) (iso.refl _)

/-- `mono_over.map f` followed by `mono_over.pullback f` is the identity. -/
def pullback_map_self (f : X ⟶ Y) [mono f] :
  map f ⋙ pullback f ≅ 𝟭 _ :=
(as_iso (mono_over.map_pullback_adj f).unit).symm

end

end map

section image
variables (f : X ⟶ Y) [has_image f]

/--
The `mono_over Y` for the image inclusion for a morphism `f : X ⟶ Y`.
-/
def image_mono_over (f : X ⟶ Y) [has_image f] : mono_over Y := mono_over.mk' (image.ι f)

@[simp] lemma image_mono_over_arrow (f : X ⟶ Y) [has_image f] :
  (image_mono_over f).arrow = image.ι f :=
rfl

end image

section image

variables [has_images C]

/--
Taking the image of a morphism gives a functor `over X ⥤ mono_over X`.
-/
@[simps]
def image : over X ⥤ mono_over X :=
{ obj := λ f, image_mono_over f.hom,
  map := λ f g k,
  begin
    apply (forget X).preimage _,
    apply over.hom_mk _ _,
    refine image.lift {I := image _, m := image.ι g.hom, e := k.left ≫ factor_thru_image g.hom},
    apply image.lift_fac,
  end }

/--
`mono_over.image : over X ⥤ mono_over X` is left adjoint to
`mono_over.forget : mono_over X ⥤ over X`
-/
def image_forget_adj : image ⊣ forget X :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ f g,
  { to_fun := λ k,
    begin
      apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _,
      change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom,
      rw [assoc, over.w k],
      apply image.fac
    end,
    inv_fun := λ k,
    begin
      refine over.hom_mk _ _,
      refine image.lift {I := g.val.left, m := g.arrow, e := k.left, fac' := over.w k},
      apply image.lift_fac,
    end,
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k,
    begin
      ext1,
      change factor_thru_image _ ≫ image.lift _ = _,
      rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom],
      exact (over.w k).symm,
    end } }

instance : is_right_adjoint (forget X) :=
{ left := image, adj := image_forget_adj }

instance reflective : reflective (forget X) := {}.

/--
Forgetting that a monomorphism over `X` is a monomorphism, then taking its image,
is the identity functor.
-/
def forget_image : forget X ⋙ image ≅ 𝟭 (mono_over X) :=
as_iso (adjunction.counit image_forget_adj)

end image

section «exists»
variables [has_images C]

/--
In the case where `f` is not a monomorphism but `C` has images,
we can still take the "forward map" under it, which agrees with `mono_over.map f`.
-/
def «exists» (f : X ⟶ Y) : mono_over X ⥤ mono_over Y :=
forget _ ⋙ over.map f ⋙ image

instance faithful_exists (f : X ⟶ Y) : faithful («exists» f) := {}.

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
def exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f ≅ map f :=
nat_iso.of_components
begin
  intro Z,
  suffices : (forget _).obj ((«exists» f).obj Z) ≅ (forget _).obj ((map f).obj Z),
    apply preimage_iso this,
  apply over.iso_mk _ _,
  apply image_mono_iso_source (Z.arrow ≫ f),
  apply image_mono_iso_source_hom_self,
end
begin
  intros Z₁ Z₂ g,
  ext1,
  change image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).hom =
         (image_mono_iso_source (Z₁.arrow ≫ f)).hom ≫ g.left,
  rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, w_assoc g, image_mono_iso_source_hom_self,
      image_mono_iso_source_hom_self],
  apply image.lift_fac,
end

/-- `exists` is adjoint to `pullback` when images exist -/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
adjunction.restrict_fully_faithful (forget X) (𝟭 _)
  ((over.map_pullback_adj f).comp _ _ image_forget_adj)
  (iso.refl _)
  (iso.refl _)

end «exists»

end mono_over

end category_theory


import sheaves.sheaf Kenny.sandbox

universes v w u₁ v₁ u

open topological_space lattice

namespace opens

variables {X : Type u} [topological_space X]

theorem Inf_eq (s : set (opens X)) : Inf s = opens.interior (Inf $ subtype.val '' s) :=
le_antisymm
  ((subset_interior_iff_subset_of_open (Inf s).2).2 $ show (Inf s).1 ≤ Inf (subtype.val '' s),
    from le_Inf $ λ t ⟨u, hus, hut⟩, le_trans interior_subset $ Inf_le ⟨u, show Inf (set.range (λ (H : u ∈ s), u.val)) = t,
    from le_antisymm (Inf_le ⟨hus, hut⟩) (le_Inf $ λ b ⟨c, hc⟩, hc ▸ ge_of_eq hut)⟩)
  (le_Inf $ λ U hus, set.subset.trans interior_subset $ show Inf (subtype.val '' s) ≤ U.1,
    from Inf_le $ set.mem_image_of_mem _ hus)

theorem inter_val (U V : opens X) : (U ∩ V).1 = U.1 ∩ V.1 := rfl
theorem inf_val (U V : opens X) : (U ⊓ V).1 = U.1 ∩ V.1 := rfl

theorem inf_Sup (U : opens X) (s : set (opens X)) : U ⊓ Sup s = Sup ((⊓) U '' s) :=
opens.ext $ by rw [inf_val, opens.Sup_s, opens.Sup_s, set.sUnion_eq_Union, set.inter_Union, ← set.image_comp]; exact
set.subset.antisymm
  (set.Union_subset $ λ ⟨t, i, his, hit⟩, set.subset_sUnion_of_mem ⟨i, his, congr_arg ((∩) U.1) hit⟩)
  (set.sUnion_subset $ λ t ⟨i, his, hit⟩, set.subset_sUnion_of_mem ⟨⟨i.1, i, his, rfl⟩, hit⟩)

def covering_inf_left (U V : opens X) (OC : covering U) : covering (V ⊓ U) :=
{ γ := OC.γ,
  Uis := λ i : OC.γ, V ⊓ OC.Uis i,
  Hcov := by conv_rhs { rw ← OC.Hcov }; rw [supr, supr, inf_Sup]; congr' 1; ext x; exact
    ⟨λ ⟨i, hix⟩, ⟨OC.Uis i, ⟨i, rfl⟩, hix⟩, λ ⟨_, ⟨i, rfl⟩, hix⟩, ⟨i, hix⟩⟩ }

def covering_res (U V : opens X) (H : V ⊆ U) (OC : covering U) : covering V :=
{ γ := OC.γ,
  Uis := λ i : OC.γ, V ⊓ OC.Uis i,
  Hcov := by erw [(covering_inf_left U V OC).Hcov, (inf_of_le_left $ show V ≤ U, from H)] }

end opens

def presheaf.covering (X : Type u) [topological_space X] : presheaf.{u (u+1)} X :=
{ F := covering,
  res := opens.covering_res,
  Hid := λ U, funext $ λ OC, by cases OC; dsimp only [opens.covering_res, id]; congr' 1; funext i; apply opens.ext;
    apply set.inter_eq_self_of_subset_right; rw ← OC_Hcov; apply set.subset_sUnion_of_mem; refine ⟨_, ⟨_, rfl⟩, rfl⟩,
  Hcomp := λ U V W HWV HVU, funext $ λ OC, by dsimp only [opens.covering_res, function.comp_apply]; congr' 1; funext i;
    rw [← lattice.inf_assoc, lattice.inf_of_le_left (show W ≤ V, from HWV)] }

def sheaf_on_opens (X : Type u) [topological_space X] (U : opens X) : Type (max u (v+1)) :=
sheaf.{u v} X

namespace sheaf_on_opens

variables {X : Type u} [topological_space X] {U : opens X}

def eval (F : sheaf_on_opens X U) (V : opens X) (HVU : V ≤ U) : Type v :=
presheaf.F F.to_presheaf V

def res (F : sheaf_on_opens X U) (V : opens X) (HVU : V ≤ U) (W : opens X) (HWU : W ≤ U) (HWV : W ≤ V) : F.eval V HVU → F.eval W HWU :=
presheaf.res _ _ _ HWV

theorem res_self (F : sheaf_on_opens X U) (V HVU HV x) :
  F.res V HVU V HVU HV x = x :=
presheaf.Hid' _ _ _

theorem res_res (F : sheaf_on_opens X U) (V HVU W HWU HWV S HSU HSW x) :
  F.res W HWU S HSU HSW (F.res V HVU W HWU HWV x) = F.res V HVU S HSU (le_trans HSW HWV) x :=
(presheaf.Hcomp' _ _ _ _ _ _ _).symm

theorem locality (F : sheaf_on_opens X U) (V HVU s t) (OC : covering V)
  (H : ∀ i : OC.γ, F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) s =
    F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) t) :
  s = t :=
F.locality OC s t H

noncomputable def glue (F : sheaf_on_opens X U) (V HVU) (OC : covering V)
  (s : Π i : OC.γ, F.eval (OC.Uis i) (le_trans (subset_covering i) HVU))
  (H : ∀ i j : OC.γ, F.res _ _ (OC.Uis i ⊓ OC.Uis j) (le_trans inf_le_left (le_trans (subset_covering i) HVU)) inf_le_left (s i) =
    F.res _ _ (OC.Uis i ⊓ OC.Uis j) (le_trans inf_le_left (le_trans (subset_covering i) HVU)) inf_le_right (s j)) :
  F.eval V HVU :=
classical.some $ F.gluing OC s H

theorem res_glue (F : sheaf_on_opens X U) (V HVU) (OC : covering V) (s H i) :
  F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) (F.glue V HVU OC s H) = s i :=
classical.some_spec (F.gluing OC s H) i

theorem eq_glue (F : sheaf_on_opens X U) (V HVU) (OC : covering V)
  (s : Π i : OC.γ, F.eval (OC.Uis i) (le_trans (subset_covering i) HVU)) (H t)
  (ht : ∀ i, F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) t = s i) :
  F.glue V HVU OC s H = t :=
F.locality V HVU _ _ OC $ λ i, by rw [res_glue, ht]

def res_subset (F : sheaf_on_opens X U) (V : opens X) (HVU : V ≤ U) : sheaf_on_opens X V :=
F

theorem res_res_subset (F : sheaf_on_opens X U) (V HVU S HSV T HTV HTS x) :
  (F.res_subset V HVU).res S HSV T HTV HTS x = F.res S (le_trans HSV HVU) T (le_trans HTV HVU) HTS x :=
rfl

def stalk (F : sheaf_on_opens.{v} X U) (x : X) (hx : x ∈ U) : Type (max u v) :=
stalk F.1 x

def to_stalk (F : sheaf_on_opens X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U) (s : F.eval V HVU) : F.stalk x hx :=
⟦⟨V, hxV, s⟩⟧

@[simp] lemma to_stalk_res (F : sheaf_on_opens X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U)
  (W : opens X) (hxW : x ∈ W) (HWV : W ≤ V) (s : F.eval V HVU) :
  F.to_stalk x hx W hxW (le_trans HWV HVU) (F.res _ _ _ _ HWV s) = F.to_stalk x hx V hxV HVU s :=
quotient.sound ⟨W, hxW, set.subset.refl W.1, HWV, by dsimp only [res]; rw ← presheaf.Hcomp'; refl⟩

@[elab_as_eliminator] theorem stalk.induction_on {F : sheaf_on_opens X U} {x : X} {hx : x ∈ U}
  {C : F.stalk x hx → Prop} (g : F.stalk x hx)
  (H : ∀ V : opens X, ∀ hxV : x ∈ V, ∀ HVU : V ≤ U, ∀ s : F.eval V HVU, C (F.to_stalk x hx V hxV HVU s)) :
  C g :=
quotient.induction_on g $ λ e,
have (⟦e⟧ : F.stalk x hx) = ⟦⟨e.1 ⊓ U, ⟨e.2, hx⟩, F.to_presheaf.res _ _ (set.inter_subset_left _ _) e.3⟩⟧,
from quotient.sound ⟨e.1 ⊓ U, ⟨e.2, hx⟩, set.inter_subset_left _ _, set.subset.refl _, by dsimp only; rw ← presheaf.Hcomp'; refl⟩,
this.symm ▸ H (e.1 ⊓ U) ⟨e.2, hx⟩ inf_le_right _

structure morphism (F : sheaf_on_opens.{v} X U) (G : sheaf_on_opens.{w} X U) : Type (max u v w) :=
(map : ∀ V ≤ U, F.eval V H → G.eval V H)
(commutes : ∀ (V : opens X) (HV : V ≤ U) (W : opens X) (HW : W ≤ U) (HWV : W ≤ V) (x),
  map W HW (F.res V HV W HW HWV x) = G.res V HV W HW HWV (map V HV x))

namespace morphism

protected def id (F : sheaf_on_opens.{v} X U) : F.morphism F :=
{ map := λ V HV, id,
  commutes := λ V HV W HW HWV x, rfl }

def comp {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) : F.morphism H :=
{ map := λ V HV x, η.map V HV (ξ.map V HV x),
  commutes := λ V HV W HW HWV x, by rw [ξ.commutes, η.commutes] }

@[simp] lemma comp_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V HV s) :
  (η.comp ξ).1 V HV s = η.1 V HV (ξ.1 V HV s) :=
rfl

@[ext] lemma ext {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U}
  {η ξ : F.morphism G} (H : ∀ V HV x, η.map V HV x = ξ.map V HV x) : η = ξ :=
by cases η; cases ξ; congr; ext; apply H

@[simp] lemma id_comp {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) :
  (morphism.id G).comp η = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_id {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) :
  η.comp (morphism.id F) = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_assoc {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U} {I : sheaf_on_opens.{v₁} X U}
  (η : H.morphism I) (ξ : G.morphism H) (χ : F.morphism G) :
  (η.comp ξ).comp χ = η.comp (ξ.comp χ) :=
rfl

def res_subset {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (F.res_subset V HVU).morphism (G.res_subset V HVU) :=
{ map := λ W HWV, η.map W (le_trans HWV HVU),
  commutes := λ S HSV T HTV, η.commutes S (le_trans HSV HVU) T (le_trans HTV HVU) }

@[simp] lemma res_subset_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U)
  (W HWV s) : (η.res_subset V HVU).1 W HWV s = η.1 W (le_trans HWV HVU) s :=
rfl

@[simp] lemma comp_res_subset {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (η.res_subset V HVU).comp (ξ.res_subset V HVU) = (η.comp ξ).res_subset V HVU :=
rfl

@[simp] lemma id_res_subset {F : sheaf_on_opens.{v} X U} (V : opens X) (HVU : V ≤ U) :
  (morphism.id F).res_subset V HVU = morphism.id (F.res_subset V HVU) :=
rfl

def stalk {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
  (s : F.stalk x hx) : G.stalk x hx :=
quotient.lift_on s (λ g, ⟦(⟨g.1 ⊓ U, (⟨g.2, hx⟩ : x ∈ g.1 ⊓ U),
  η.map _ inf_le_right (presheaf.res F.1 _ _ (set.inter_subset_left _ _) g.3)⟩ : stalk.elem _ _)⟧) $
λ g₁ g₂ ⟨V, hxV, HV1, HV2, hg⟩, quotient.sound ⟨V ⊓ U, ⟨hxV, hx⟩, set.inter_subset_inter_left _ HV1, set.inter_subset_inter_left _ HV2,
calc  G.res _ _ (V ⊓ U) inf_le_right (inf_le_inf HV1 (le_refl _)) (η.map (g₁.U ⊓ U) inf_le_right (F.to_presheaf.res (g₁.U) (g₁.U ⊓ U) (set.inter_subset_left _ _) (g₁.s)))
    = η.map (V ⊓ U) inf_le_right (F.to_presheaf.res V (V ⊓ U) (set.inter_subset_left _ _) (F.to_presheaf.res (g₁.U) V HV1 (g₁.s))) : by rw [← η.2, res, ← presheaf.Hcomp', ← presheaf.Hcomp']
... = G.res _ _ (V ⊓ U) _ _ (η.map (g₂.U ⊓ U) inf_le_right (F.to_presheaf.res (g₂.U) (g₂.U ⊓ U) _ (g₂.s))) : by rw [hg, ← η.2, res, ← presheaf.Hcomp', ← presheaf.Hcomp']⟩

@[simp] lemma stalk_to_stalk {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
  (V : opens X) (HVU : V ≤ U) (hxV : x ∈ V) (s : F.eval V HVU) : η.stalk x hx (F.to_stalk x hx V hxV HVU s) = G.to_stalk x hx V hxV HVU (η.map V HVU s) :=
quotient.sound ⟨V, hxV, set.subset_inter (set.subset.refl _) HVU, set.subset.refl _,
calc  G.res (V ⊓ U) inf_le_right V HVU (le_inf (le_refl V) HVU) (η.map (V ⊓ U) inf_le_right (F.res V HVU (V ⊓ U) inf_le_right inf_le_left s))
    = G.res V HVU V HVU (le_refl V) (η.map V HVU s) : by rw [η.2, res_res]⟩

end morphism

structure equiv (F : sheaf_on_opens.{v} X U) (G : sheaf_on_opens.{w} X U) : Type (max u v w) :=
(to_fun : morphism F G)
(inv_fun : morphism G F)
(left_inv : ∀ V HVU s, inv_fun.1 V HVU (to_fun.1 V HVU s) = s)
(right_inv : ∀ V HVU s, to_fun.1 V HVU (inv_fun.1 V HVU s) = s)

namespace equiv

def refl (F : sheaf_on_opens.{v} X U) : equiv F F :=
⟨morphism.id F, morphism.id F, λ _ _ _, rfl, λ _ _ _, rfl⟩

@[simp] lemma refl_apply (F : sheaf_on_opens.{v} X U) (V HV s) :
  (refl F).1.1 V HV s = s := rfl

def symm {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{v} X U} (e : equiv F G) : equiv G F :=
⟨e.2, e.1, e.4, e.3⟩

def trans {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{v} X U} {H : sheaf_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) : equiv F H :=
⟨e₂.1.comp e₁.1, e₁.2.comp e₂.2,
λ _ _ _, by rw [morphism.comp_apply, morphism.comp_apply, e₂.3, e₁.3],
λ _ _ _, by rw [morphism.comp_apply, morphism.comp_apply, e₁.4, e₂.4]⟩

@[simp] lemma trans_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{v} X U} {H : sheaf_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) (V HV s) :
  (e₁.trans e₂).1.1 V HV s = e₂.1.1 V HV (e₁.1.1 V HV s) :=
rfl

def res_subset {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) : equiv (F.res_subset V HVU) (G.res_subset V HVU) :=
⟨e.1.res_subset V HVU, e.2.res_subset V HVU,
λ _ _ _, by rw [morphism.res_subset_apply, morphism.res_subset_apply, e.3],
λ _ _ _, by rw [morphism.res_subset_apply, morphism.res_subset_apply, e.4]⟩

@[simp] lemma res_subset_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) (W HW s) :
  (e.res_subset V HVU).1.1 W HW s = e.1.1 W (le_trans HW HVU) s :=
rfl

def stalk {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (e : equiv F G) (x : X) (hx : x ∈ U) :
  F.stalk x hx ≃ G.stalk x hx :=
{ to_fun := e.1.stalk x hx,
  inv_fun := e.2.stalk x hx,
  left_inv := λ g, stalk.induction_on g $ λ V hxV HVU s, by rw [morphism.stalk_to_stalk, morphism.stalk_to_stalk, e.3],
  right_inv := λ g, stalk.induction_on g $ λ V hxV HVU s, by rw [morphism.stalk_to_stalk, morphism.stalk_to_stalk, e.4] }

end equiv

namespace sheaf_glue

variables {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
variables (φ : Π (i j : I), equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
variables (Hφ1 : ∀ i, φ i i = equiv.refl (res_subset (F i) (S i ⊓ S i) _))
variables (Hφ2 : ∀ i j k,
  ((φ i j).res_subset ((S i) ⊓ (S j) ⊓ (S k)) inf_le_left).trans
    ((φ j k).res_subset ((S i) ⊓ (S j) ⊓ (S k)) (le_inf (le_trans inf_le_left inf_le_right) inf_le_right)) =
  (φ i k).res_subset ((S i) ⊓ (S j) ⊓ (S k)) (le_inf (le_trans inf_le_left inf_le_left) inf_le_right))

@[reducible] def compat (W : opens X) : Type (max u v) :=
{ f : Π i, (F i).eval ((S i) ⊓ W) inf_le_left //
  ∀ i j, (φ i j).1.map ((S i) ⊓ (S j) ⊓ W) inf_le_left
    ((F i).res ((S i) ⊓ W) _ _ (le_trans inf_le_left inf_le_left)
      (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
      (f i)) =
    (F j).res ((S j) ⊓ W) _ _ (le_trans inf_le_left inf_le_right)
      (le_inf (le_trans inf_le_left inf_le_right) inf_le_right)
      (f j) }

def res (U V : opens X) (HVU : V ≤ U) (f : compat S F φ U) : compat S F φ V :=
⟨λ i, (F i).res (S i ⊓ U) _ (S i ⊓ V) _ (inf_le_inf (le_refl _) HVU) (f.1 i), λ i j,
calc  (φ i j).1.map (S i ⊓ S j ⊓ V) inf_le_left
        (res (F i) (S i ⊓ V) inf_le_left (S i ⊓ S j ⊓ V)
          (le_trans inf_le_left inf_le_left)
          (le_inf (le_trans inf_le_left inf_le_left)
              inf_le_right)
          (res (F i) (S i ⊓ U) inf_le_left (S i ⊓ V) inf_le_left
              (inf_le_inf (le_refl _) HVU)
              (f.1 i)) : (F i).eval (S i ⊓ S j ⊓ V) (le_trans _ _))
    = (φ i j).1.map (S i ⊓ S j ⊓ V) inf_le_left
        (res (res_subset (F i) (S i ⊓ S j) inf_le_left) (S i ⊓ S j ⊓ U) inf_le_left
          (S i ⊓ S j ⊓ V)
          inf_le_left
          (inf_le_inf (le_refl _) HVU)
          (res (F i) (S i ⊓ U) inf_le_left (S i ⊓ S j ⊓ U)
            (le_trans inf_le_left inf_le_left)
            (le_inf (le_trans inf_le_left inf_le_left)
                inf_le_right)
            (f.1 i) : (F i).eval (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_left))) :
  by rw [res_res_subset, res_res, res_res]
... = (res (F j) (S j ⊓ V) inf_le_left (S i ⊓ S j ⊓ V)
        (le_trans inf_le_left inf_le_right)
        (le_inf (le_trans inf_le_left inf_le_right)
          inf_le_right)
        (res (F j) (S j ⊓ U) inf_le_left (S j ⊓ V) inf_le_left
          (inf_le_inf (le_refl _) HVU)
          (f.1 j)) : (F j).eval (S i ⊓ S j ⊓ V) _) :
  by rw [(φ i j).1.commutes, f.2 i j, res_res_subset, res_res, res_res]⟩

theorem locality (U : opens X) (OC : covering U) (s t : sheaf_glue.compat S F φ U)
  (H : ∀ i : OC.γ, sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) s =
    sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) t) :
  s = t :=
subtype.eq $ funext $ λ i, (F i).locality _ _ _ _ (opens.covering_inf_left U (S i) OC) $ λ j,
by have := H j; simp only [sheaf_glue.res, subtype.mk.inj_eq] at this; exact congr_fun this i

noncomputable def gluing.aux1 (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j))
  (i : I) : (F i).eval (S i ⊓ U) inf_le_left :=
(F i).glue _ _ (opens.covering_inf_left U (S i) OC) (λ j, (s j).1 i) $ λ j k,
have h1 : S i ⊓ OC.Uis j ⊓ (S i ⊓ OC.Uis k) ≤ S i ⊓ (OC.Uis j ⊓ OC.Uis k),
by rw [inf_assoc, inf_left_comm (OC.Uis j), ← inf_assoc, inf_idem]; exact le_refl _,
have h2 : S i ⊓ (OC.Uis j ⊓ OC.Uis k) ≤ S i ⊓ OC.Uis j,
from inf_le_inf (le_refl _) inf_le_left,
have h3 : S i ⊓ (OC.Uis j ⊓ OC.Uis k) ≤ S i ⊓ OC.Uis k,
from inf_le_inf (le_refl _) inf_le_right,
have (F i).res (S i ⊓ OC.Uis j) _ (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) inf_le_left h2 ((s j).1 i) =
  (F i).res (S i ⊓ OC.Uis k) _ (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) inf_le_left h3 ((s k).1 i),
from congr_fun (congr_arg subtype.val (H j k)) i,
calc  _
    = (F i).res (S i ⊓ OC.Uis j) _ ((S i ⊓ OC.Uis j) ⊓ (S i ⊓ OC.Uis k)) _ _ ((s j).1 i) : rfl
... = (F i).res (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) _ ((S i ⊓ OC.Uis j) ⊓ (S i ⊓ OC.Uis k)) _ h1
        ((F i).res (S i ⊓ OC.Uis j) _ (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) inf_le_left h2 ((s j).1 i)) : (res_res _ _ _ _ _ _ _ _ _ _).symm
... = (F i).res (S i ⊓ OC.Uis k) _ ((S i ⊓ OC.Uis j) ⊓ (S i ⊓ OC.Uis k)) _ inf_le_right ((s k).1 i) : by rw [this, res_res]

theorem gluing.aux2 (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j)) (i j : I) :
  (φ i j).1.map (S i ⊓ S j ⊓ U) inf_le_left
      ((F i).res (S i ⊓ U) _ (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_left)
        (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
        (gluing.aux1 S F φ U OC s H i)) =
    (F j).res (S j ⊓ U) _ (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_right)
      (by rw inf_assoc; exact inf_le_right)
      (gluing.aux1 S F φ U OC s H j) :=
(F j).locality _ _ _ _ (opens.covering_inf_left _ _ OC) $ λ k,
calc  ((F j).res_subset (S i ⊓ S j) inf_le_right).res (S i ⊓ S j ⊓ U) inf_le_left ((S i ⊓ S j) ⊓ OC.Uis k) inf_le_left
        (inf_le_inf (le_refl _) (subset_covering k))
        ((φ i j).1.map (S i ⊓ S j ⊓ U) inf_le_left
          ((F i).res (S i ⊓ U) _ (S i ⊓ S j ⊓ U) _
            (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
            (gluing.aux1 S F φ U OC s H i)))
    = (φ i j).1.map (S i ⊓ S j ⊓ OC.Uis k) inf_le_left
        ((F i).res ((opens.covering_inf_left U (S i) OC).Uis k) _ _ (le_trans inf_le_left inf_le_left)
          (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
          ((F i).res (S i ⊓ U) _ ((opens.covering_inf_left U (S i) OC).Uis k) inf_le_left
            (inf_le_inf (le_refl _) (subset_covering k))
            (gluing.aux1 S F φ U OC s H i))) : by rw [← (φ i j).1.commutes, res_res_subset, res_res, res_res]
... = (F j).res ((opens.covering_inf_left U (S j) OC).Uis k) _ ((S i ⊓ S j) ⊓ OC.Uis k) _
        (by rw inf_assoc; exact inf_le_right)
        ((F j).res (S j ⊓ U) _ ((opens.covering_inf_left U (S j) OC).Uis k) inf_le_left
          (inf_le_inf (le_refl _) (subset_covering k))
          (gluing.aux1 S F φ U OC s H j)) : by erw [res_glue, res_glue]; exact (s k).2 i j
... = (F j).res (S i ⊓ S j ⊓ U) _ ((S i ⊓ S j) ⊓ OC.Uis k) _ _
        ((F j).res (S j ⊓ U) _ (S i ⊓ S j ⊓ U) _ _ (gluing.aux1 S F φ U OC s H j)) : by rw [res_res, res_res]; refl

theorem gluing.aux3 (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j)) (i : OC.γ) :
  sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) ⟨λ i, gluing.aux1 S F φ U OC s H i, gluing.aux2 S F φ U OC s H⟩ = s i :=
subtype.eq $ funext $ λ j, by dsimp only [gluing.aux1, sheaf_glue.res];
change (F j).res _ _ ((opens.covering_inf_left U (S j) OC).Uis i) _ _ _ = _;
erw res_glue

theorem gluing (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j)) :
  ∃ t : sheaf_glue.compat S F φ U, ∀ i : OC.γ, sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) t = s i :=
⟨⟨λ i, gluing.aux1 S F φ U OC s H i, gluing.aux2 S F φ U OC s H⟩, λ i, gluing.aux3 S F φ U OC s H i⟩

end sheaf_glue

def sheaf_glue {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right)) :
  sheaf_on_opens.{max u v} X (⋃S) :=
{ F := sheaf_glue.compat S F φ,
  res := sheaf_glue.res S F φ,
  Hid := λ U, funext $ λ f, subtype.eq $ funext $ λ i, by dsimp only [sheaf_glue.res, id]; rw res_self,
  Hcomp := λ U V W HWV HVU, funext $ λ f, subtype.eq $ funext $ λ i, by symmetry; apply res_res; exact inf_le_left,
  locality := sheaf_glue.locality S F φ,
  gluing := sheaf_glue.gluing S F φ }

@[simp] lemma sheaf_glue_res_val {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (U HU V HV HVU s i) : ((sheaf_glue S F φ).res U HU V HV HVU s).1 i = (F i).res _ _ _ _ (inf_le_inf (le_refl _) HVU) (s.1 i) := rfl

def universal_property (I : Type u) (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (Hφ1 : ∀ i V HV s, (φ i i).1.1 V HV s = s)
  (Hφ2 : ∀ i j k V HV1 HV2 HV3 s, (φ j k).1.1 V HV1 ((φ i j).1.1 V HV2 s) = (φ i k).1.1 V HV3 s)
  (i : I) :
  equiv (res_subset (sheaf_glue S F φ) (S i) (le_supr S i)) (F i) :=
{ to_fun :=
  { map := λ U H s, (F i).res _ _ _ _ (le_inf H (le_refl _)) (s.1 i),
    commutes := λ U HU V HV HVU s, by rw [res_res, res_res_subset]; dsimp only [res, sheaf_glue, sheaf_glue.res]; rw ← presheaf.Hcomp'; refl },
  inv_fun :=
  { map := λ U H s, ⟨λ j, (φ i j).1.1 (S j ⊓ U) (le_inf (le_trans inf_le_right H) inf_le_left)
        ((F i).res _ _ _ (le_trans inf_le_right H) inf_le_right s),
      λ j k, begin
        have h1 : S j ⊓ S k ⊓ U ≤ S i ⊓ S j := le_inf (le_trans inf_le_right H) (le_trans inf_le_left inf_le_left),
        have h2 : S j ⊓ S k ⊓ U ≤ S i ⊓ S k := le_inf (le_trans inf_le_right H) (le_trans inf_le_left inf_le_right),
        rw [← res_res_subset (F j) _ _ _ _ _ h1, ← (φ i j).1.2, Hφ2 _ _ _ _ _ _ h2, res_res_subset, res_res],
        rw [← res_res_subset (F k) _ _ _ _ _ h2, ← (φ i k).1.2, res_res_subset, res_res],
      end⟩,
    commutes := λ U HU V HV HVU s, subtype.eq $ funext $ λ j, by dsimp only [res_res_subset, sheaf_glue_res_val];
      rw [← res_res_subset (F j), ← (φ i j).1.2, res_res_subset, res_res, res_res] },
  left_inv := λ V HV s, subtype.eq $ funext $ λ j, have _, from s.2 i j, calc
      _ = (φ i j).1.map (S j ⊓ V) (le_inf (le_trans inf_le_right HV) inf_le_left)
            ((F i).res V HV (S j ⊓ V) (le_trans inf_le_right HV) inf_le_right
              ((F i).res (S i ⊓ V) _ V HV (le_inf HV (le_refl _)) (s.1 i))) : rfl
    ... = (φ i j).1.map (S j ⊓ V) _
            ((F i).res (S i ⊓ V) _ (S j ⊓ V) _ _ (s.1 i)) : by rw res_res
    ... = (φ i j).1.map (S j ⊓ V) _
            (((F i).res_subset (S i ⊓ S j) _).res ((S i ⊓ S j) ⊓ V) inf_le_left _ _
              (by rw [inf_assoc, inf_left_comm, inf_of_le_right HV]; exact le_refl _)
              ((F i).res (S i ⊓ V) _ ((S i ⊓ S j) ⊓ V) (le_trans inf_le_left inf_le_left)
                (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
                (s.1 i))) : by rw [res_res_subset, res_res]
    ... = s.1 j : by rw [(φ i j).1.2, s.2 i j, res_res_subset, res_res, res_self],
  right_inv := λ V HV s, by dsimp only; erw [Hφ1, res_res, res_self] }

end sheaf_on_opens