import condensed.is_proetale_sheaf
import condensed.adjunctions
import category_theory.limits.filtered_colimit_commutes_finite_limit
import for_mathlib.AddCommGroup.explicit_limits

open category_theory
open category_theory.limits

universe u
variables
  {J : Type (u+1)} [small_category J] [is_filtered J]
  {C : Type (u+2)}
  [category.{u+1} C]
  [concrete_category.{u+1} C]
  [has_limits C]
  [has_colimits_of_shape J C]
  [preserves_colimits_of_shape J (forget C)]
  [reflects_limits (forget C)]
  [preserves_limits (forget C)]
  (F : J ⥤ Condensed.{u} C)

open opposite

namespace is_sheaf_colimit_presheaf_aux

namespace empty

variables (G : J ⥤ Profinite.{u}ᵒᵖ ⥤ C)

noncomputable
def comparison_component (j : J) :
  (G.obj j).obj (op Profinite.empty) ⟶ ⊤_ _ := terminal.from _

variables [∀ j, is_iso (comparison_component G j)]

noncomputable
def first_iso : (colimit G).obj (op Profinite.empty) ≅
  colimit (limit (functor.empty _ ⋙ G.flip)) :=
let e₁ := is_colimit_of_preserves ((evaluation _ _).obj (op Profinite.empty))
  (colimit.is_colimit G),
    e₂ := e₁.cocone_point_unique_up_to_iso (colimit.is_colimit _),
    e₃ : G ⋙ (evaluation Profiniteᵒᵖ C).obj (op Profinite.empty) ≅
      limit (functor.empty Profiniteᵒᵖ ⋙ G.flip) :=
      nat_iso.of_components
      (λ j,
        let e₄ := is_limit_of_preserves ((evaluation _ _).obj j)
          (limit.is_limit (functor.empty _ ⋙ G.flip)),
            e₅ := (limit.is_limit _).cone_point_unique_up_to_iso e₄,
            e₆ : functor.empty C ≅
              (functor.empty Profiniteᵒᵖ ⋙ G.flip) ⋙ (evaluation J C).obj j :=
              nat_iso.of_components (λ i, i.as.elim) (λ i, i.as.elim) in
        as_iso (comparison_component G j) ≪≫
          has_limit.iso_of_nat_iso e₆ ≪≫ e₅)
      begin
        intros X Y f, dsimp [comparison_component],
        apply (is_limit_of_preserves ((evaluation J C).obj Y)
          (limit.is_limit (functor.empty Profiniteᵒᵖ ⋙ G.flip))).hom_ext,
        intros j, rcases j with ⟨⟨⟩⟩
      end in
e₂ ≪≫ has_colimit.iso_of_nat_iso e₃

-- Move this!
noncomputable
instance preserves_finite_limits_of_concrete :
  preserves_finite_limits (colim : (J ⥤ C) ⥤ C) :=
begin
  apply preserves_finite_limits_of_preserves_finite_limits_of_size,
  introsI K _ _,
  exact limits.filtered_colim_preserves_finite_limits,
end

noncomputable
def second_iso : colimit (limit (functor.empty.{0} _ ⋙ G.flip)) ≅
  limit (colimit (functor.empty.{0} _ ⋙ G.flip).flip) :=
(is_limit_of_preserves colim (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _) ≪≫
  (has_limit.iso_of_nat_iso (colimit_flip_iso_comp_colim _).symm)
--colimit_limit_iso _ -- TODO: Fix universes in `colimit_limit_iso`.

noncomputable
def third_iso : limit (colimit (functor.empty _ ⋙ G.flip).flip) ≅ ⊤_ _ :=
has_limit.iso_of_nat_iso $ nat_iso.of_components (λ i, i.as.elim) (λ i, i.as.elim)

noncomputable
def comparison : (colimit G).obj (op Profinite.empty) ⟶ ⊤_ _ := terminal.from _

theorem is_iso_comparison : is_iso (comparison G) :=
begin
  suffices : comparison G = (first_iso G).hom ≫ (second_iso G).hom ≫ (third_iso G).hom,
  { rw this, apply_instance },
  simp,
end

end empty

namespace prod

variables (X Y : Profinite.{u}) (G : J ⥤ Profinite.{u}ᵒᵖ ⥤ C)

noncomputable
def comparison_component (j : J) :
  (G.obj j).obj (op $ Profinite.sum X Y) ⟶ prod ((G.obj j).obj (op X)) ((G.obj j).obj (op Y)) :=
prod.lift ((G.obj j).map (Profinite.sum.inl _ _).op) ((G.obj j).map (Profinite.sum.inr _ _).op)

variables [∀ j, is_iso (comparison_component X Y G j)]

noncomputable
def first_iso_aux_aux (j) :
  (G ⋙ (evaluation Profiniteᵒᵖ C).obj (op (X.sum Y))).obj j ≅
  (G.flip.obj (op X) ⨯ G.flip.obj (op Y)).obj j :=
let e₄ : pair ((G.obj j).obj (op X)) ((G.obj j).obj (op Y)) ≅
  pair (G.flip.obj (op X)) (G.flip.obj (op Y)) ⋙ (evaluation J C).obj j :=
  nat_iso.of_components
  (λ p, match p with
    | discrete.mk walking_pair.left := iso.refl _
    | discrete.mk walking_pair.right := iso.refl _
    end) begin
      rintros (_|_) (_|_) (_|_), refl, refl,
    end in
as_iso (comparison_component X Y G j) ≪≫
  has_limit.iso_of_nat_iso e₄ ≪≫
  (limit.is_limit _).cone_point_unique_up_to_iso
    (is_limit_of_preserves ((evaluation _ _).obj j) (limit.is_limit _))

noncomputable
def first_iso_aux : G ⋙ (evaluation Profiniteᵒᵖ C).obj (op (X.sum Y)) ≅
  G.flip.obj (op X) ⨯ G.flip.obj (op Y) :=
nat_iso.of_components (λ j, first_iso_aux_aux X Y G j)
begin
  intros i j f, dsimp [comparison_component, first_iso_aux_aux],
  apply
    (is_limit_of_preserves ((evaluation J C).obj j)
      (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).hom_ext,
  rintros (_|_),
  { dsimp [is_limit.cone_point_unique_up_to_iso],
    have h1 :=
      (is_limit_of_preserves ((evaluation J C).obj j)
        (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).fac
          (limit.cone _) (discrete.mk walking_pair.left),
    have h2 :=
      (is_limit_of_preserves ((evaluation J C).obj i)
        (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).fac
          (limit.cone _) (discrete.mk walking_pair.left),
    dsimp at h1 h2, simp [h1, reassoc_of h2],
    dsimp [first_iso_aux_aux._match_1], simp },
  { dsimp [is_limit.cone_point_unique_up_to_iso],
    have h1 :=
      (is_limit_of_preserves ((evaluation J C).obj j)
        (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).fac
          (limit.cone _) (discrete.mk walking_pair.right),
    have h2 :=
      (is_limit_of_preserves ((evaluation J C).obj i)
        (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).fac
          (limit.cone _) (discrete.mk walking_pair.right),
    dsimp at h1 h2, simp [h1, reassoc_of h2],
    dsimp [first_iso_aux_aux._match_1], simp },
end

noncomputable
def first_iso : (colimit G).obj (op $ Profinite.sum X Y) ≅
  colimit (prod (G.flip.obj (op X)) (G.flip.obj (op Y))) :=
let e₁ := is_colimit_of_preserves ((evaluation _ _).obj (op $ Profinite.sum X Y))
  (colimit.is_colimit G),
    e₂ := e₁.cocone_point_unique_up_to_iso (colimit.is_colimit _) in
e₂ ≪≫ has_colimit.iso_of_nat_iso (first_iso_aux X Y G)

noncomputable
def second_iso : colimit (prod (G.flip.obj (op X)) (G.flip.obj (op Y))) ≅
  limit (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip) :=
(is_limit_of_preserves colim (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _) ≪≫
  (has_limit.iso_of_nat_iso (colimit_flip_iso_comp_colim _).symm)
--colimit_limit_iso _

noncomputable
def third_iso_aux_left :
  (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip).obj (discrete.mk walking_pair.left) ≅
  (colimit G).obj (op X) :=
let e₁ :=
  is_colimit_of_preserves ((evaluation _ _).obj (discrete.mk walking_pair.left))
    (colimit.is_colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip),
    e₂ :=
  is_colimit_of_preserves ((evaluation _ _).obj (op X))
    (colimit.is_colimit G) in
e₁.cocone_point_unique_up_to_iso e₂

noncomputable
def third_iso_aux_right :
  (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip).obj (discrete.mk walking_pair.right) ≅
  (colimit G).obj (op Y) :=
let e₁ :=
  is_colimit_of_preserves ((evaluation _ _).obj (discrete.mk walking_pair.right))
    (colimit.is_colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip),
    e₂ :=
  is_colimit_of_preserves ((evaluation _ _).obj (op Y))
    (colimit.is_colimit G) in
e₁.cocone_point_unique_up_to_iso e₂

/--/
noncomputable
def third_iso_aux : cone (pair (op X) (op Y) ⋙ colimit G) :=
{ X := limit (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip),
  π :=
  { app := λ p,
    match p with
    | walking_pair.left := limit.π _ walking_pair.left ≫ (third_iso_aux_left X Y G).hom
    | walking_pair.right := limit.π _ walking_pair.right ≫ (third_iso_aux_right X Y G).hom
    end,
    naturality' := admit } }

noncomputable
def third_iso_aux' : cone (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip) :=
{ X := limit (pair (op X) (op Y) ⋙ colimit G),
  π :=
  { app := λ p,
    match p with
    | walking_pair.left := limit.π _ walking_pair.left ≫ (third_iso_aux_left X Y G).inv
    | walking_pair.right := limit.π _ walking_pair.right ≫ (third_iso_aux_right X Y G).inv
    end,
    naturality' := admit } }
-/

noncomputable
def third_iso_aux : cone (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip) :=
{ X := prod ((colimit G).obj (op X)) ((colimit G).obj (op Y)),
  π :=
  { app := λ p,
    match p with
    | discrete.mk walking_pair.left := limits.prod.fst ≫ (third_iso_aux_left _ _ _).inv
    | discrete.mk walking_pair.right := limits.prod.snd ≫ (third_iso_aux_right _ _ _).inv
    end,
    naturality' := begin
      rintros (_|_) (_|_) (_|_),
      { dsimp [third_iso_aux._match_1], simp },
      { dsimp [third_iso_aux._match_1], simp },
    end } }

noncomputable
def third_iso :
  limit (colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip)
    ≅ prod ((colimit G).obj (op X)) ((colimit G).obj (op Y)) :=
{ hom := prod.lift
    (limit.π _ (discrete.mk walking_pair.left) ≫ (third_iso_aux_left _ _ _).hom)
    (limit.π _ (discrete.mk walking_pair.right) ≫ (third_iso_aux_right _ _ _).hom),
  inv := limit.lift _ (third_iso_aux _ _ _),
  hom_inv_id' := begin
    ext (_|_),
    { simp only [category.assoc, limit.lift_π, category.id_comp],
      dsimp [third_iso_aux, third_iso_aux._match_1], simp },
    { simp only [category.assoc, limit.lift_π, category.id_comp],
      dsimp [third_iso_aux, third_iso_aux._match_1], simp },
  end,
  inv_hom_id' := begin
    ext,
    { simp only [prod.comp_lift, limit.lift_π_assoc, prod.lift_fst, category.id_comp],
      dsimp [third_iso_aux], simp, },
    { simp only [prod.comp_lift, limit.lift_π_assoc, prod.lift_snd, category.id_comp],
      dsimp [third_iso_aux], simp, },
  end }

/-
noncomputable
def fourth_iso_aux : cone (pair (op X) (op Y) ⋙ colimit G) :=
{ X := prod ((colimit G).obj (op X)) ((colimit G).obj (op Y)),
  π :=
  { app := λ p,
    match p with
    | walking_pair.left := limits.prod.fst
    | walking_pair.right := limits.prod.snd
    end,
    naturality' := admit } }

noncomputable
def fourth_iso : limit (pair (op X) (op Y) ⋙ colimit G) ≅
  prod ((colimit G).obj (op X)) ((colimit G).obj (op Y)) :=
{ hom := prod.lift (limit.π _ walking_pair.left) (limit.π _ walking_pair.right),
  inv := limit.lift _ (fourth_iso_aux _ _ _),
  hom_inv_id' := admit,
  inv_hom_id' := admit }
-/

noncomputable
def comparison : (colimit G).obj (op $ Profinite.sum X Y) ⟶
  prod ((colimit G).obj (op X)) ((colimit G).obj (op Y)) :=
prod.lift
  ((colimit G).map (Profinite.sum.inl _ _).op)
  ((colimit G).map (Profinite.sum.inr _ _).op)

lemma is_iso_comparison_aux_fst (j) :
  (colimit.ι G j).app (op (X.sum Y)) ≫ comparison X Y G ≫ limits.prod.fst =
    (colimit.ι G j).app (op (X.sum Y)) ≫
      (first_iso X Y G).hom ≫ (second_iso X Y G).hom ≫ (third_iso X Y G).hom ≫
      limits.prod.fst :=
begin
  dsimp [comparison, first_iso, second_iso, third_iso, colimit_limit_iso],
  simp only [prod.comp_lift, prod.lift_fst, category.assoc,
    has_limit.iso_of_nat_iso_hom_π_assoc, iso.symm_hom,
    colimit_flip_iso_comp_colim_inv_app,
    limit.cone_point_unique_up_to_iso_hom_comp_assoc, functor.map_cone_π_app,
    binary_fan.π_app_left],
  dsimp [has_colimit.iso_of_nat_iso, colim, colim_map, is_colimit.map,
    is_colimit.cocone_point_unique_up_to_iso,
    colimit_obj_iso_colimit_comp_evaluation,
    third_iso_aux, third_iso_aux_left, preserves_colimit_iso],
  have := (is_colimit_of_preserves
    ((evaluation Profiniteᵒᵖ C).obj (op (X.sum Y)))
    (colimit.is_colimit G)).fac _ j,
  dsimp at this, slice_rhs 1 2 { rw this }, clear this,
  simp only [colimit.cocone_ι, colimit.ι_desc, cocones.precompose_obj_ι,
    nat_trans.comp_app, category.assoc, flip_comp_evaluation_inv_app,
    functor.map_cocone_ι_app, evaluation_obj_map],
  dsimp [first_iso_aux, first_iso_aux_aux, comparison_component,
    is_limit.cone_point_unique_up_to_iso],
  simp only [has_limit.lift_iso_of_nat_iso_hom_assoc,
    category.id_comp, category.assoc],
  have := (is_limit_of_preserves ((evaluation J C).obj j)
    (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).fac _
      (discrete.mk walking_pair.left), dsimp at this,
  slice_rhs 2 3 { rw this }, clear this,
  simp only [limit.cone_π, category.assoc, limit.lift_π_assoc,
    cones.postcompose_obj_π, nat_trans.comp_app, nat_iso.of_components_hom_app],
  have := (is_colimit_of_preserves ((evaluation _ C).obj (discrete.mk walking_pair.left))
    (colimit.is_colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip)).fac _ j,
  dsimp at this, slice_rhs 3 4 { rw this }, clear this,
  dsimp [first_iso_aux_aux._match_1], simp only [category.id_comp, nat_trans.naturality],
end

lemma is_iso_comparison_aux_snd (j) : (colimit.ι G j).app (op (X.sum Y)) ≫ comparison X Y G ≫
  limits.prod.snd = (colimit.ι G j).app (op (X.sum Y)) ≫
    (first_iso X Y G).hom ≫ (second_iso X Y G).hom ≫ (third_iso X Y G).hom ≫
    limits.prod.snd :=
begin
  dsimp [comparison, first_iso, second_iso, third_iso, colimit_limit_iso],
  simp only [prod.comp_lift, prod.lift_snd, category.assoc,
    has_limit.iso_of_nat_iso_hom_π_assoc, iso.symm_hom,
    colimit_flip_iso_comp_colim_inv_app,
    limit.cone_point_unique_up_to_iso_hom_comp_assoc, functor.map_cone_π_app,
    binary_fan.π_app_right],
  dsimp [has_colimit.iso_of_nat_iso, colim, colim_map, is_colimit.map,
    is_colimit.cocone_point_unique_up_to_iso,
    colimit_obj_iso_colimit_comp_evaluation,
    third_iso_aux, third_iso_aux_right, preserves_colimit_iso],
  have := (is_colimit_of_preserves
    ((evaluation Profiniteᵒᵖ C).obj (op (X.sum Y)))
    (colimit.is_colimit G)).fac _ j,
  dsimp at this, slice_rhs 1 2 { rw this }, clear this,
  simp only [colimit.cocone_ι, colimit.ι_desc, cocones.precompose_obj_ι,
    nat_trans.comp_app, category.assoc, flip_comp_evaluation_inv_app,
    functor.map_cocone_ι_app, evaluation_obj_map],
  dsimp [first_iso_aux, first_iso_aux_aux, comparison_component,
    is_limit.cone_point_unique_up_to_iso],
  simp only [has_limit.lift_iso_of_nat_iso_hom_assoc,
    category.id_comp, category.assoc],
  have := (is_limit_of_preserves ((evaluation J C).obj j)
    (limit.is_limit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))))).fac _
      (discrete.mk walking_pair.right), dsimp at this,
  slice_rhs 2 3 { rw this }, clear this,
  simp only [limit.cone_π, category.assoc, limit.lift_π_assoc,
    cones.postcompose_obj_π, nat_trans.comp_app, nat_iso.of_components_hom_app],
  have := (is_colimit_of_preserves ((evaluation _ C).obj (discrete.mk walking_pair.right))
    (colimit.is_colimit (pair (G.flip.obj (op X)) (G.flip.obj (op Y))).flip)).fac _ j,
  dsimp at this, slice_rhs 3 4 { rw this }, clear this,
  dsimp [first_iso_aux_aux._match_1], simp only [category.id_comp, nat_trans.naturality],
end

lemma is_iso_comparison : is_iso (comparison X Y G) :=
begin
  suffices : (comparison X Y G) =
    (first_iso X Y G).hom ≫ (second_iso X Y G).hom ≫ (third_iso X Y G).hom,
  { rw this, apply_instance },
  ext,
  { simp only [category.assoc, is_iso_comparison_aux_fst] },
  { simp only [category.assoc, is_iso_comparison_aux_snd] }
end

end prod

namespace eq

variables {X Y : Profinite.{u}} (f : X ⟶ Y) (G : J ⥤ Profinite.{u}ᵒᵖ ⥤ C)

noncomputable
def comparison_component (j : J) :
  (G.obj j).obj (op $ Y) ⟶
  equalizer
    ((G.obj j).map (Profinite.pullback.fst f f).op)
    ((G.obj j).map (Profinite.pullback.snd f f).op) :=
equalizer.lift ((G.obj j).map f.op)
begin
  simp_rw [← (G.obj j).map_comp, ← op_comp, Profinite.pullback.condition],
end

variables [∀ j, is_iso (comparison_component f G j)]

def first_iso_aux_aux (j) : parallel_pair ((G.obj j).map (Profinite.pullback.fst f f).op)
  ((G.obj j).map (Profinite.pullback.snd f f).op) ≅
    parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
  (G.flip.map (Profinite.pullback.snd f f).op) ⋙
    (evaluation J C).obj j :=
nat_iso.of_components (λ p,
  match p with
  | walking_parallel_pair.zero := iso.refl _
  | walking_parallel_pair.one := iso.refl _
  end)
begin
  rintro (_|_) (_|_) (_|_),
  refl,
  dsimp [first_iso_aux_aux._match_1], simp,
  dsimp [first_iso_aux_aux._match_1], simp,
  refl,
end

noncomputable
def first_iso_aux : G ⋙ (evaluation Profiniteᵒᵖ C).obj (op Y) ≅
  equalizer (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op) :=
nat_iso.of_components (λ j,
  as_iso (comparison_component f G j)
    ≪≫
    has_limit.iso_of_nat_iso (first_iso_aux_aux _ _ _)
    ≪≫ (limit.is_limit _).cone_point_unique_up_to_iso
    (is_limit_of_preserves ((evaluation _ _).obj j) (limit.is_limit _)))
begin
  intros i j g, dsimp [comparison_component, first_iso_aux_aux],
  apply (is_limit_of_preserves ((evaluation J C).obj j)
    (limit.is_limit
    (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)))).hom_ext,
  rintros (_|_),
  { dsimp [is_limit.cone_point_unique_up_to_iso],
    have := (is_limit_of_preserves ((evaluation J C).obj j)
      (limit.is_limit
      (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)))).fac (limit.cone _)
      walking_parallel_pair.zero,
    dsimp at this, simp only [category.assoc, this], clear this,
    have := (is_limit_of_preserves ((evaluation J C).obj i)
      (limit.is_limit
      (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)))).fac (limit.cone _)
      walking_parallel_pair.zero,
    dsimp at this, simp only [nat_trans.naturality, category.assoc, reassoc_of this], clear this,
    simp only [has_limit.iso_of_nat_iso_hom_π, nat_iso.of_components_hom_app,
      equalizer.lift_ι_assoc, functor.flip_obj_map, has_limit.iso_of_nat_iso_hom_π_assoc],
    dsimp [first_iso_aux_aux._match_1],
    simp only [category.comp_id, category.id_comp, nat_trans.naturality] },
  { dsimp [is_limit.cone_point_unique_up_to_iso],
    have := (is_limit_of_preserves ((evaluation J C).obj j)
      (limit.is_limit
      (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)))).fac (limit.cone _)
      walking_parallel_pair.one,
    dsimp at this, simp only [category.assoc, this], clear this,
    have := (is_limit_of_preserves ((evaluation J C).obj i)
      (limit.is_limit
      (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)))).fac (limit.cone _)
      walking_parallel_pair.one,
    dsimp at this, simp only [nat_trans.naturality, category.assoc, reassoc_of this], clear this,
    simp only [has_limit.iso_of_nat_iso_hom_π, nat_iso.of_components_hom_app,
      limit.lift_π_assoc, fork.of_ι_π_app, category.assoc, functor.flip_obj_map,
      has_limit.iso_of_nat_iso_hom_π_assoc],
    dsimp [first_iso_aux_aux._match_1],
    simp only [category.comp_id, category.id_comp,
      nat_trans.naturality, nat_trans.naturality_assoc] }
end

noncomputable
def first_iso : (colimit G).obj (op $ Y) ≅
  colimit (equalizer
    (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)) :=
let e₁ := is_colimit_of_preserves
  ((evaluation _ _).obj (op $ Y)) (colimit.is_colimit G),
    e₂ := e₁.cocone_point_unique_up_to_iso (colimit.is_colimit _) in
e₂ ≪≫ has_colimit.iso_of_nat_iso (first_iso_aux f G)

noncomputable
def second_iso : colimit (equalizer
    (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)) ≅
    limit (colimit (parallel_pair
      (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)).flip) :=
(is_limit_of_preserves colim (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _) ≪≫
  (has_limit.iso_of_nat_iso (colimit_flip_iso_comp_colim _).symm)
--colimit_limit_iso _

noncomputable
def third_iso_aux :
  (colimit (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip).obj
    walking_parallel_pair.zero ≅ (colimit G).obj (op X) :=
let e₁ :=
  is_colimit_of_preserves ((evaluation _ _).obj walking_parallel_pair.zero)
    (colimit.is_colimit (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip),
    e₂ := is_colimit_of_preserves ((evaluation _ _).obj (op X)) (colimit.is_colimit G) in
e₁.cocone_point_unique_up_to_iso e₂

noncomputable
def third_iso_aux'' :
  (colimit (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip).obj
    walking_parallel_pair.one ≅ (colimit G).obj (op $ Profinite.pullback f f) :=
let e₁ :=
  is_colimit_of_preserves ((evaluation _ _).obj walking_parallel_pair.one)
    (colimit.is_colimit (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip),
    e₂ := is_colimit_of_preserves ((evaluation _ _).obj (op $ Profinite.pullback f f))
    (colimit.is_colimit G) in
e₁.cocone_point_unique_up_to_iso e₂

lemma third_iso_aux_fst :
    (third_iso_aux f G).inv ≫ (colimit
    (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip).map
    walking_parallel_pair_hom.left = (colimit G).map (Profinite.pullback.fst f f).op ≫
    (third_iso_aux'' f G).inv :=
begin
  dsimp [third_iso_aux, third_iso_aux''],
  apply (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj
  (op X)) (colimit.is_colimit G)).hom_ext, intros j,
  dsimp [is_colimit.cocone_point_unique_up_to_iso],
  have h1 := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj (op X))
    (colimit.is_colimit G)).fac _ j,
  have h2 := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj
    (op $ Profinite.pullback f f)) (colimit.is_colimit G)).fac _ j,
  dsimp at h1 h2,
  slice_lhs 1 2 { rw h1 }, clear h1,
  rw ← nat_trans.naturality_assoc,
  slice_rhs 2 3 { rw h2 }, clear h2,
  dsimp, rw ← nat_trans.naturality, refl
end

lemma third_iso_aux_snd :
    (third_iso_aux f G).inv ≫ (colimit
    (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip).map
    walking_parallel_pair_hom.right = (colimit G).map (Profinite.pullback.snd f f).op ≫
    (third_iso_aux'' f G).inv :=
begin
  dsimp [third_iso_aux, third_iso_aux''],
  apply (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj
  (op X)) (colimit.is_colimit G)).hom_ext, intros j,
  dsimp [is_colimit.cocone_point_unique_up_to_iso],
  have h1 := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj (op X))
    (colimit.is_colimit G)).fac _ j,
  have h2 := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj
    (op $ Profinite.pullback f f)) (colimit.is_colimit G)).fac _ j,
  dsimp at h1 h2,
  slice_lhs 1 2 { rw h1 }, clear h1,
  rw ← nat_trans.naturality_assoc,
  slice_rhs 2 3 { rw h2 }, clear h2,
  dsimp, rw ← nat_trans.naturality, refl
end

noncomputable
def third_iso_aux' : cone (colimit (parallel_pair
      (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)).flip) :=
{ X := equalizer
      ((colimit G).map (Profinite.pullback.fst f f).op)
      ((colimit G).map (Profinite.pullback.snd f f).op),
  π :=
  { app := λ p,
    match p with
    | walking_parallel_pair.zero := equalizer.ι _ _ ≫ (third_iso_aux _ _).inv
    | walking_parallel_pair.one := equalizer.ι _ _ ≫ (third_iso_aux f G).inv ≫
        category_theory.functor.map _ walking_parallel_pair_hom.left
    end,
  naturality' := begin
    rintro (_|_) (_|_) ⟨⟩,
    { dsimp, simp only [category.id_comp, category_theory.functor.map_id, category.comp_id], },
    { dsimp [third_iso_aux'._match_1], simp only [category.id_comp, category.assoc], },
    { dsimp [third_iso_aux'._match_1], simp only [category.id_comp, category.assoc],
      rw [third_iso_aux_fst, third_iso_aux_snd],
      simp only [category.assoc, equalizer.condition_assoc] },
    { dsimp, simp only [category.id_comp, category_theory.functor.map_id, category.comp_id], },
  end } }

noncomputable
def third_iso : limit (colimit (parallel_pair
      (G.flip.map (Profinite.pullback.fst f f).op)
      (G.flip.map (Profinite.pullback.snd f f).op)).flip) ≅
    equalizer
      ((colimit G).map (Profinite.pullback.fst f f).op)
      ((colimit G).map (Profinite.pullback.snd f f).op) :=
{ hom := equalizer.lift
    (limit.π _ walking_parallel_pair.zero ≫ (third_iso_aux f G).hom) begin
      have := third_iso_aux_fst f G, rw iso.eq_comp_inv at this, rw ← this, clear this,
      have := third_iso_aux_snd f G, rw iso.eq_comp_inv at this, rw ← this, clear this,
      simp only [category.assoc, iso.hom_inv_id_assoc],
      simp only [← category.assoc], congr' 1,
      let F := _, change limit.π F _ ≫ F.map _ = limit.π F _ ≫ F.map _,
      simp [limit.w F walking_parallel_pair_hom.left],
    end,
  inv := limit.lift _ (third_iso_aux' _ _),
  hom_inv_id' := begin
    ext (_|_),
    { simp only [category.assoc, limit.lift_π, category.id_comp],
      dsimp [third_iso_aux', third_iso_aux'._match_1],
      simp only [equalizer.lift_ι_assoc, category.assoc, iso.hom_inv_id, category.comp_id] },
    { simp only [category.assoc, limit.lift_π, category.id_comp],
      dsimp [third_iso_aux', third_iso_aux'._match_1],
      simp only [equalizer.lift_ι_assoc, category.assoc, iso.hom_inv_id_assoc,
        category.comp_id, category.id_comp, limit.w] }
  end,
  inv_hom_id' := begin
    ext,
    simp only [category.assoc, equalizer.lift_ι, limit.lift_π_assoc, category.id_comp],
    dsimp [third_iso_aux, third_iso_aux'],
    simp only [category.assoc, iso.inv_hom_id, category.comp_id],
  end }

noncomputable
def comparison :
  (colimit G).obj (op $ Y) ⟶
  equalizer
    ((colimit G).map (Profinite.pullback.fst f f).op)
    ((colimit G).map (Profinite.pullback.snd f f).op) :=
equalizer.lift ((colimit G).map f.op)
begin
  simp only [← functor.map_comp, ← op_comp, Profinite.pullback.condition],
end

theorem is_iso_comparison : is_iso (comparison f G) :=
begin
  suffices : comparison f G =
    (first_iso f G).hom ≫ (second_iso f G).hom ≫ (third_iso f G).hom,
  { rw this, apply_instance },
  ext,
  dsimp [comparison, first_iso, second_iso, third_iso, colimit_limit_iso],
  simp only [category.assoc, equalizer.lift_ι, has_limit.iso_of_nat_iso_hom_π_assoc,
    iso.symm_hom, colimit_flip_iso_comp_colim_inv_app,
    limit.cone_point_unique_up_to_iso_hom_comp_assoc, functor.map_cone_π_app,
    equalizer.fork_π_app_zero],
  dsimp [has_colimit.iso_of_nat_iso, is_colimit.cocone_point_unique_up_to_iso,
    colim, colim_map, is_colimit.map, colimit_obj_iso_colimit_comp_evaluation,
    preserves_colimit_iso, third_iso_aux],
  have := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ C).obj (op Y))
    (colimit.is_colimit G)).fac _ j, dsimp at this,
  slice_rhs 1 2 { rw this }, clear this,
  simp only [colimit.cocone_ι, colimit.ι_desc, cocones.precompose_obj_ι, nat_trans.comp_app,
    category.assoc, flip_comp_evaluation_inv_app, functor.map_cocone_ι_app, evaluation_obj_map],
  dsimp [first_iso_aux, comparison_component],
  simp only [has_limit.lift_iso_of_nat_iso_hom_assoc, category.id_comp, category.assoc],
  dsimp [is_limit.cone_point_unique_up_to_iso],
  have := (is_colimit_of_preserves ((evaluation walking_parallel_pair C).obj
    walking_parallel_pair.zero) (colimit.is_colimit
    (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)).flip)).fac _ j,
  dsimp at this, slice_rhs 4 5 { rw this }, clear this,
  have := (is_limit_of_preserves ((evaluation J C).obj j)
    (limit.is_limit (parallel_pair (G.flip.map (Profinite.pullback.fst f f).op)
    (G.flip.map (Profinite.pullback.snd f f).op)))).fac _ walking_parallel_pair.zero,
  dsimp at this ⊢, slice_rhs 2 3 { erw this }, clear this,
  dsimp,
  simp only [limit.lift_π_assoc, cones.postcompose_obj_π, nat_trans.comp_app,
    fork.of_ι_π_app, category.assoc],
  dsimp [first_iso_aux_aux],
  simp only [category.id_comp, nat_trans.naturality],
end

end eq

end is_sheaf_colimit_presheaf_aux
open is_sheaf_colimit_presheaf_aux

/-
variables {K : Type (u+1)} [small_category K] [fin_category K]
  (E : K ⥤ Profinite.{u}ᵒᵖ) [has_limit E] (G : J ⥤ Profinite.{u}ᵒᵖ ⥤ C)
  [∀ j, preserves_limits_of_shape K (G.obj j)]

noncomputable
def comparison_map_component (j : J) : (G.obj j).obj (limit E) ⟶ limit (E ⋙ G.obj j) :=
limit.lift (E ⋙ G.obj j) $ (G.obj j).map_cone (limit.cone E)

noncomputable
def comparison_map : (colimit G).obj (limit E) ⟶ limit (E ⋙ colimit G) :=
limit.lift (E ⋙ colimit G) $ (colimit G).map_cone (limit.cone E)

noncomputable
def first_iso : (colimit G).obj (limit E) ≅ colimit (limit (E ⋙ G.flip)) :=
let e := is_colimit_of_preserves ((evaluation _ _).obj (limit E))
  (colimit.is_colimit G),
  ee := e.cocone_point_unique_up_to_iso (colimit.is_colimit _),
  tt : G ⋙ (evaluation Profiniteᵒᵖ C).obj (limit E) ≅ limit (E ⋙ G.flip) :=
    nat_iso.of_components (λ j, begin
      dsimp,
      refine (is_limit_of_preserves (G.obj j) (limit.is_limit E)).cone_point_unique_up_to_iso
        (limit.is_limit _) ≪≫ _,
      refine _ ≪≫ (limit.is_limit _).cone_point_unique_up_to_iso
        ((is_limit_of_preserves ((evaluation _ _).obj j) (limit.is_limit _))),
      dsimp,
      refine has_limit.iso_of_nat_iso _,
      refine nat_iso.of_components _ _,
      intros k, exact iso.refl _,
      intros k₁ k₂ f, dsimp, simp,
    end) admit in
ee ≪≫ has_colimit.iso_of_nat_iso tt

noncomputable
def second_iso : colimit (limit (E ⋙ G.flip)) ≅ limit (colimit (E ⋙ G.flip).flip) :=
  colimit_limit_iso _

noncomputable
def third_iso : limit (colimit (E ⋙ G.flip).flip) ≅ limit (E ⋙ colimit G) :=
has_limit.iso_of_nat_iso $
nat_iso.of_components (λ k,
  let ee := (is_colimit_of_preserves ((evaluation _ _).obj k)
    (colimit.is_colimit (E ⋙ G.flip).flip)).cocone_point_unique_up_to_iso
    (colimit.is_colimit _) in
  ee ≪≫
  begin
    dsimp,
    refine _ ≪≫
      (colimit.is_colimit _).cocone_point_unique_up_to_iso
      ((is_colimit_of_preserves ((evaluation _ _).obj (E.obj k)) (colimit.is_colimit _))),
    dsimp,
    refine has_colimit.iso_of_nat_iso _,
    refine nat_iso.of_components _ _,
    intros j, exact iso.refl _,
    intros i j f, dsimp, simp,
  end) admit

lemma is_iso : is_iso (comparison_map E G) :=
begin
  suffices : comparison_map E G =
    (first_iso E G).hom ≫ (second_iso E G).hom ≫ (third_iso E G).hom,
  { rw this, apply_instance },
  admit,
end

-- Use the comparison map above
variable (K)
def key : preserves_limits_of_shape K (colimit G) := admit

end is_sheaf_colimit_presheaf_aux
open is_sheaf_colimit_presheaf_aux

theorem empty_condition_iff_preserves (G : Profiniteᵒᵖ ⥤ C) :
  G.empty_condition' ↔
  nonempty (preserves_limits_of_shape (discrete pempty.{u+1}) G) := admit

theorem product_condition_iff_preserves (G : Profiniteᵒᵖ ⥤ C) :
  G.product_condition' ↔
  nonempty (preserves_limits_of_shape (discrete walking_pair.{u+1}) G) := admit

theorem equalizer_condition_iff_preserves (G : Profiniteᵒᵖ ⥤ C) :
  G.equalizer_condition' ↔
  nonempty (preserves_limits_of_shape (walking_parallel_pair.{u+1}) G) := admit
-/

lemma is_sheaf_colimit_presheaf :
  presheaf.is_sheaf proetale_topology (colimit (F ⋙ Sheaf_to_presheaf _ _)) :=
begin
  --rw is_sheaf_iff_is_sheaf_of_type,
  let G := (colimit (F ⋙ Sheaf_to_presheaf _ _)),
  let Gs := F ⋙ Sheaf_to_presheaf _ _,
  have hGs : ∀ j, presheaf.is_sheaf proetale_topology (Gs.obj j),
  { intros j, exact (F.obj j).2 },
  have hGsempty : ∀ j, (Gs.obj j).empty_condition',
  { intros j, specialize hGs j,
    rw (Gs.obj j).is_proetale_sheaf_tfae.out 0 3 at hGs,
    exact hGs.1 },
  have hGsprod : ∀ j, (Gs.obj j).product_condition',
  { intros j, specialize hGs j,
    rw (Gs.obj j).is_proetale_sheaf_tfae.out 0 3 at hGs,
    exact hGs.2.1 },
  have hGseq : ∀ j, (Gs.obj j).equalizer_condition',
  { intros j, specialize hGs j,
    rw (Gs.obj j).is_proetale_sheaf_tfae.out 0 3 at hGs,
    exact hGs.2.2 },
  rw G.is_proetale_sheaf_tfae.out 0 3,
  refine ⟨_,_,_⟩,
  { apply_with empty.is_iso_comparison { instances := ff },
    exact hGsempty,
    all_goals { apply_instance } },
  { intros X Y,
    apply_with prod.is_iso_comparison { instances := ff },
    intros j, apply hGsprod,
    all_goals { apply_instance } },
  { intros X Y f hf,
    apply_with eq.is_iso_comparison { instances := ff },
    intros j, apply hGseq, assumption' }
end

@[simps]
noncomputable
def filtered_cocone : cocone F :=
{ X := ⟨colimit (F ⋙ Sheaf_to_presheaf _ _), is_sheaf_colimit_presheaf _⟩,
  ι :=
  { app := λ j, Sheaf.hom.mk $ colimit.ι (F ⋙ Sheaf_to_presheaf _ _) j,
    naturality' := begin
      intros i j f,
      ext1, dsimp,
      simpa using colimit.w (F ⋙ Sheaf_to_presheaf _ _) f,
    end } }

noncomputable
def filtered_cocone_is_colimit : is_colimit (filtered_cocone F) :=
{ desc := λ S, Sheaf.hom.mk $ colimit.desc (F ⋙ Sheaf_to_presheaf _ _)
    ((Sheaf_to_presheaf _ _).map_cocone S),
  fac' := begin
    intros S j,
    ext1, dsimp,
    simp,
  end,
  uniq' := begin
    intros S m hm,
    ext1, dsimp,
    apply colimit.hom_ext,
    intros j, specialize hm j, apply_fun (λ e, e.val) at hm,
    dsimp at hm, simpa using hm,
  end } .

section

local attribute [-simp] forget_map_eq_coe

noncomputable
def preserves_limits_aux_1 (G : J ⥤ Condensed.{u} Ab.{u+1}) :
  colimit (G ⋙ Sheaf_to_presheaf proetale_topology Ab) ⋙ forget Ab ≅
  colimit (G ⋙ Sheaf_to_presheaf _ _ ⋙ (whiskering_right _ _ _).obj (forget Ab)) :=
nat_iso.of_components
begin
  intros X,
  let E := (G ⋙ Sheaf_to_presheaf _ _ ⋙ (whiskering_right _ _ _).obj (forget Ab)),
  let e₀ := colimit.is_colimit E,
  let e₁ := is_colimit_of_preserves ((evaluation _ _).obj X) e₀,
  refine _ ≪≫ (colimit.is_colimit _).cocone_point_unique_up_to_iso e₁,
  change (forget Ab).obj _ ≅ colimit _,
  let e₂ := colimit.is_colimit (G ⋙ Sheaf_to_presheaf proetale_topology Ab),
  let e₃ := is_colimit_of_preserves ((evaluation _ _).obj X) e₂,
  let e₄ := e₃.cocone_point_unique_up_to_iso (colimit.is_colimit _),
  refine (forget Ab).map_iso e₄ ≪≫ _,
  change (forget Ab).obj (colimit _) ≅ _,
  let e₅ := is_colimit_of_preserves (forget Ab)
    (colimit.is_colimit ((G ⋙ Sheaf_to_presheaf proetale_topology Ab)
    ⋙ (evaluation Profiniteᵒᵖ Ab).obj X)),
  exact e₅.cocone_point_unique_up_to_iso (colimit.is_colimit _),
end
begin
  intros X Y f, dsimp, simp only [category.assoc],
  dsimp [is_colimit.cocone_point_unique_up_to_iso],
  let E₀ := is_colimit_of_preserves ((evaluation Profiniteᵒᵖ Ab).obj X)
    (colimit.is_colimit (G ⋙ Sheaf_to_presheaf proetale_topology Ab)),
  let E := is_colimit_of_preserves (forget Ab) E₀,
  apply E.hom_ext, intros j, dsimp,

  -- Let's work on the LHS

  slice_lhs 1 3
  { simp only [← (forget Ab).map_comp],
    rw ← ((colimit.ι (G ⋙ Sheaf_to_presheaf proetale_topology Ab) j)).naturality_assoc, },
  have := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ Ab).obj Y)
    (colimit.is_colimit (G ⋙ Sheaf_to_presheaf proetale_topology Ab))).fac _ j,
  dsimp at this, rw this, clear this,
  dsimp,
  have := (is_colimit_of_preserves (forget Ab)
    (colimit.is_colimit ((G ⋙ Sheaf_to_presheaf proetale_topology Ab) ⋙
    (evaluation Profiniteᵒᵖ Ab).obj Y))).fac _ j,
  simp only [(forget Ab).map_comp, category.assoc],
  dsimp at this, slice_lhs 2 3 { rw this }, clear this,
  erw colimit.ι_desc,

  -- Now for the RHS

  slice_rhs 1 2 { rw ← (forget Ab).map_comp },
  have := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ Ab).obj X)
    (colimit.is_colimit (G ⋙ Sheaf_to_presheaf proetale_topology Ab))).fac _ j,
  dsimp at this, rw this, clear this,
  have := (is_colimit_of_preserves (forget Ab)
    (colimit.is_colimit ((G ⋙ Sheaf_to_presheaf proetale_topology Ab) ⋙
    (evaluation Profiniteᵒᵖ Ab).obj X))).fac _ j,
  dsimp at this, slice_rhs 1 2 { erw this }, clear this, erw colimit.ι_desc,
  dsimp, erw ← nat_trans.naturality, refl,
end

local attribute [-simp] types_comp_apply functor_to_types.comp

noncomputable
def preserves_limits_of_shape_of_filtered_aux (G : J ⥤ Condensed.{u} Ab.{u+1}) :
  Condensed_Ab_to_CondensedSet.{u}.map_cocone (filtered_cocone G) ≅
  filtered_cocone (G ⋙ Condensed_Ab_to_CondensedSet.{u}) :=
cocones.ext
{ hom := Sheaf.hom.mk $ (preserves_limits_aux_1 G).hom,
  inv := Sheaf.hom.mk $ (preserves_limits_aux_1 G).inv,
  hom_inv_id' := by { ext1, simp },
  inv_hom_id' := by { ext1, simp } }
begin
  intros j, ext, dsimp [preserves_limits_aux_1, is_colimit.cocone_point_unique_up_to_iso],

  simp only [← category.assoc, ← (forget Ab).map_comp],
  have := (is_colimit_of_preserves ((evaluation Profiniteᵒᵖ Ab).obj x)
    (colimit.is_colimit (G ⋙ Sheaf_to_presheaf proetale_topology Ab))).fac _ j,
  dsimp at this, rw this, clear this, dsimp, simp only [category.assoc],
  have := (is_colimit_of_preserves (forget Ab)
    (colimit.is_colimit ((G ⋙ Sheaf_to_presheaf proetale_topology Ab) ⋙
    (evaluation Profiniteᵒᵖ Ab).obj x))).fac _ j,
  dsimp at this, simp only [← category.assoc], rw this, clear this, erw colimit.ι_desc,
  refl,

end

end

noncomputable
instance Condensed_Ab_to_CondensedSet_preserves_limits_of_shape_of_filtered :
  preserves_colimits_of_shape J Condensed_Ab_to_CondensedSet.{u} :=
begin
  constructor,
  intros G,
  apply preserves_colimit_of_preserves_colimit_cocone (filtered_cocone_is_colimit G),
  apply is_colimit.of_iso_colimit (filtered_cocone_is_colimit
    (G ⋙ Condensed_Ab_to_CondensedSet)),
  exact (preserves_limits_of_shape_of_filtered_aux G).symm,
end


import «smt-lean»

example {x y : ℤ} (h1 : ((x - y) = (x + (- y) + 2)))
 : false :=
begin
  veriT,
end


import topology.basic
import category_theory.basic
import category_theory.instances
import category_theory.universal_properties.product
import category_theory.universal_properties.colimit

universes v v₁ v₂ u u₁ u₂

open classical
open category
open topology
open set

/-
  We have a category C with obj in Type u and mor in Type v, we'd like to think of C
  as being at least locally small so we will of v as being the level of sets.

-/

def inc_to_mor {X : Type u} [topology X] {O₁ O₂ : Open X} : inclusion O₁ O₂ →
  inclusion (op O₁).val (op O₂).val :=
begin
  intro,
  simp [op_val],
  assumption,
end

noncomputable def open_cover_res {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] (𝓕 : opposite (Open X) +→ C) {U : Open X} {I : Type v} {f : I → Open X}
  (hf : is_open_cover f U) : Mor (𝓕.map (op U)) (Π₀ (λ i : I, 𝓕.map (op (f i)))).1 :=
  into_product (λ i : I, 𝓕.fmap (inc_to_mor (is_open_cover_includes hf i)))

def inter_index {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] (𝓕 : opposite (Open X) +→ C) {I : Type v} (f : I → Open X)
  : I → I → C := λ i j , 𝓕.map (op (f i ∩ f j))

def inter_res_b_left {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] (𝓕 : opposite (Open X) +→ C) {I : Type v} (f : I → Open X)
  (i : I) : Π j : I, Mor (𝓕.map (op (f i))) (inter_index 𝓕 f i j) := λ j,𝓕.fmap (inc_to_mor (inter_inc_left (f i) (f j)))

noncomputable def intersection_res_left {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] (𝓕 : opposite (Open X) +→ C) {I : Type v} (f : I → Open X)
  : Mor (Π₀ (λ i : I, 𝓕.map (op (f i)))).1 (Π₀ (λ ij : I × I, 𝓕.map (op (f ij.1 ∩ f ij.2)))).1
  := (prod_can_iso (double_prod_prod_left (inter_index 𝓕 f)) (has_product_prod_is_prod
     (function.uncurry (inter_index 𝓕 f))))
     ∘ₘ Πₘ (λ i : I, into_product (λ j, 𝓕.fmap (inc_to_mor (inter_inc_left (f i) (f j)))))

noncomputable def intersection_res_right {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] (𝓕 : opposite (Open X) +→ C) {I : Type v} (f : I → Open X)
  : Mor (Π₀ (λ i : I, 𝓕.map (op (f i)))).1 (Π₀ (λ ij : I × I, 𝓕.map (op (f ij.1 ∩ f ij.2)))).1
  := (prod_can_iso (double_prod_prod_right (inter_index 𝓕 f)) (has_product_prod_is_prod
     (function.uncurry (inter_index 𝓕 f))))
     ∘ₘ Πₘ (λ j : I, into_product (λ i, 𝓕.fmap (inc_to_mor (inter_inc_right (f i) (f j)))))

structure sheaf (X : Type v) [topology X] (C : Type u) [category.{v} C] [has_products.{v u v} C]
  [has_small_filtered_colimits C] :=
(body : opposite (Open X) +→ C)
(res_exact_seq : ∀ {U : Open X} {I : Type v} {f : I → Open X} (hf : is_open_cover f U),
  is_equaliser (intersection_res_left body f) (intersection_res_right body f)
  ⟨body.map (op U), open_cover_res body hf⟩)

namespace sheaf

theorem op_open_sets_at_a_point_filtered_category {X : Type v} [topology X] (p : X)
  : filtered_category (opposite ({O : Open X // p ∈ O})) :=
begin
  split,
  intros i₁ i₂,
  cases i₁ with O₁,
  cases i₂ with O₂,
  have hp : p ∈ (O₁ ∩ O₂ : Open X),
    exact ⟨O₁.property, O₂.property⟩,
  existsi op (subtype.mk (O₁ ∩ O₂ : Open X) hp),
  split,
  split,
  apply inc_to_mor,
  simp,
  apply inter_inc_left,
  split,
  apply inc_to_mor,
  simp,
  apply inter_inc_right,
  intros i j f₁ f₂,
  existsi j,
  existsi idₘ j,
  apply inclusion_equality,
end

def stalk_shape {X : Type v} [topology X] {C : Type u} [category.{v} C] [has_products.{v u v} C]
  [has_small_filtered_colimits C] (𝓕 : sheaf X C) (p : X) : opposite ({O: Open X // p ∈ O}) +→ C
  := 𝓕.body ⊚ (op_functor (open_at_point_forget p))

noncomputable def stalk {X : Type v} [topology X] {C : Type u} [category.{v} C] [has_products.{v u v} C]
  [has_small_filtered_colimits C] (𝓕 : sheaf X C) (p : X)
  : Σ st : C, (Π oOp : opposite ({O: Open X // p ∈ O}), Mor ((stalk_shape 𝓕 p).map oOp) st)
  := filtered_colimit (op_open_sets_at_a_point_filtered_category p) (stalk_shape 𝓕 p)

theorem stalk_property {X : Type v} [topology X] {C : Type u} [category.{v} C] [has_products.{v u v} C]
  [has_small_filtered_colimits C] (𝓕 : sheaf X C) (p : X)
  : is_colimit (stalk_shape 𝓕 p) (stalk 𝓕 p)
  := filtered_colimit_property (op_open_sets_at_a_point_filtered_category p) (stalk_shape 𝓕 p)

instance sheaf_category (X : Type v) [topology X] (C : Type u) [category.{v} C] [has_products.{v u v} C]
  [has_small_filtered_colimits C] : category (sheaf X C) :=
{
  Mor := λ 𝓕₁ 𝓕₂, 𝓕₁.body →ₙ 𝓕₂.body,
  idₘ := λ 𝓕, idₙ 𝓕.body,
  comp := λ F₁ F₂ F₃ φ₁ φ₂, φ₁ ∘ₙ φ₂,
  comp_assoc :=
    begin
      intros F₁ F₂ F₃ F₄ φ₁ φ₂ φ₃,
      apply natural_trans_equality,
      apply funext,
      intro,
      simp,
      rw comp_assoc,
    end,
  id_comp_left :=
    begin
      intros F₁ F₂ φ,
      apply natural_trans_equality,
      apply funext,
      intro,
      rw natural_trans_comp_map,
      simp,
      rw id_comp_left,
    end,
  id_comp_right :=
    begin
      intros F₁ F₂ φ,
      apply natural_trans_equality,
      apply funext,
      intro,
      rw natural_trans_comp_map,
      simp,
      rw id_comp_right,
    end,
}

noncomputable def natural_trans_im_cocone {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] {𝓕₁ 𝓕₂ : sheaf X C} (φ : Mor 𝓕₁ 𝓕₂)
  (p : X) : Σ c : C, Π O : opposite {O : Open X // p ∈ O}, Mor (𝓕₁.body.map (op O.val)) c
  := ⟨(stalk 𝓕₂ p).1, λ O : opposite {O : Open X // p ∈ O}, ((stalk 𝓕₂ p).2 ( O))∘ₘ(φ.map (op O.val))⟩

theorem natural_trans_im_cocone_obj {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] {𝓕₁ 𝓕₂ : sheaf X C}
  (φ : Mor 𝓕₁ 𝓕₂) (p : X) : (natural_trans_im_cocone φ p).1 = (stalk 𝓕₂ p).1 := rfl

theorem natural_trans_im_cocone_map {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] {𝓕₁ 𝓕₂ : sheaf X C}
  (φ : Mor 𝓕₁ 𝓕₂) (p : X) : (natural_trans_im_cocone φ p).2 = λ O : opposite {O : Open X // p ∈ O},
  ((stalk 𝓕₂ p).2 O) ∘ₘ (φ.map (op O.val)) := rfl

theorem existance_of_induced_morphism_of_stalks_nat {X : Type v} [topology X] {C : Type u}
  [category.{v} C] [has_products.{v u v} C] [has_small_filtered_colimits C]
  {𝓕₁ 𝓕₂ : sheaf X C} (φ : Mor 𝓕₁ 𝓕₂) (p : X) : ∃! φₚ : Mor (stalk 𝓕₁ p).1 (stalk 𝓕₂ p).1,
   ∀ O : opposite {O : Open X// p ∈ O}, ((stalk 𝓕₂ p).2 O) ∘ₘ (φ.map (op O.val))
   = φₚ ∘ₘ ((stalk 𝓕₁ p).2 O) :=
begin
  have hcc : is_cocone (stalk_shape 𝓕₁ p) (natural_trans_im_cocone φ p),
    intros O₁ O₂ i₂₁,
    have hrw₁ : (stalk_shape 𝓕₁ p).fmap i₂₁ = 𝓕₁.body.fmap i₂₁ := rfl,
    have hrw₂ : (stalk_shape 𝓕₂ p).fmap i₂₁ = 𝓕₂.body.fmap i₂₁ := rfl,
    rw [hrw₁,← comp_assoc,← φ.natural,comp_assoc],
    have h𝓕₁ := (stalk_property 𝓕₂ p).1 ,
    simp,
    have hrw₄ : (stalk 𝓕₂ p).2 O₁ = ((stalk 𝓕₂ p).2 O₂) ∘ₘ 𝓕₂.body.fmap i₂₁,
      cases stalk 𝓕₂ p,
      apply h𝓕₁,
    rw hrw₄,
    refl,
  -- what follows is mere abstract nonsense.
  have hint := (stalk_property 𝓕₁ p).2 (natural_trans_im_cocone φ p) hcc,
  rw natural_trans_im_cocone_map φ p at hint,
  cases hint with φₚ hφₚ,
  simp [natural_trans_im_cocone_obj] at hφₚ,
  existsi φₚ,
  exact hφₚ,
end

noncomputable def induced_mor_of_stalks_nat {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] {𝓕₁ 𝓕₂ : sheaf X C} (φ : Mor 𝓕₁ 𝓕₂)
  (p : X) : Mor (stalk 𝓕₁ p).1 (stalk 𝓕₂ p).1 := some (existance_of_induced_morphism_of_stalks_nat φ p)

theorem induced_mor_of_stalks_nat_property {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] {𝓕₁ 𝓕₂ : sheaf X C} (φ : Mor 𝓕₁ 𝓕₂) (p : X)
  : (∀ O : opposite {O : Open X// p ∈ O}, ((stalk 𝓕₂ p).2 O) ∘ₘ (φ.map (op O.val))
     = (induced_mor_of_stalks_nat φ p) ∘ₘ ((stalk 𝓕₁ p).2 O)) ∧
     (∀ φₚ, (∀ O, ((stalk 𝓕₂ p).2 O) ∘ₘ (φ.map (op O.val)) = φₚ ∘ₘ ((stalk 𝓕₁ p).2 O))
     → φₚ = (induced_mor_of_stalks_nat φ p)) := some_spec (existance_of_induced_morphism_of_stalks_nat φ p)

theorem induced_mor_of_stalks_nat_compose {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] {𝓕₁ 𝓕₂ 𝓕₃: sheaf X C} (φ₁ : Mor 𝓕₂ 𝓕₃)
  (φ₂ : Mor 𝓕₁ 𝓕₂) (p : X) : induced_mor_of_stalks_nat (φ₁ ∘ₘ φ₂) p = (induced_mor_of_stalks_nat φ₁ p)
    ∘ₘ (induced_mor_of_stalks_nat φ₂ p) :=
begin
  symmetry,
  apply (induced_mor_of_stalks_nat_property (φ₁ ∘ₘ φ₂) p).2,
  intro,
  cases induced_mor_of_stalks_nat_property φ₁ p with hrw₁ up₁,
  cases induced_mor_of_stalks_nat_property φ₂ p with hrw₂ up₂,
  rw [←comp_assoc, ←hrw₂, comp_assoc, ←hrw₁],
  have hrw₃ : φ₁ ∘ₘ φ₂  = φ₁ ∘ₙ φ₂ := rfl,
  simp [hrw₃,comp_assoc],
end

theorem induced_mor_of_stalks_nat_id {X : Type v} [topology X] {C : Type u} [category.{v} C]
  [has_products.{v u v} C] [has_small_filtered_colimits C] (𝓕 : sheaf X C) (p : X)
  : induced_mor_of_stalks_nat (idₘ 𝓕) p = idₘ (stalk 𝓕 p).1 :=
begin
  symmetry,
  apply (induced_mor_of_stalks_nat_property (idₘ 𝓕) p).2,
  intro,
  have hrw₁ : idₘ 𝓕 = idₙ 𝓕.body := rfl,
  have hrw₂ : (idₙ 𝓕.body).map (op ↑(O.val)) = idₘ (𝓕.body.map (op ↑(O.val))) := rfl,
  have hrw₃ : idₘ ((stalk_shape 𝓕 p).map O) = idₘ (𝓕.body.map (op ↑(O.val))) := rfl,
  rw [hrw₁,hrw₂,← hrw₃,id_comp_left],
  dsimp,
  rw id_comp_right ((stalk 𝓕 p).2 O),
end

noncomputable def stalk_of_nat_trans {X : Type v} [topology X] (C : Type u) [category.{v} C]
  [has_products.{v u v} C]
  [has_small_filtered_colimits C] (p : X) : sheaf X C +→ C :=
{
  map := λ 𝓕, (stalk 𝓕 p).1,
  fmap := λ _ _ φ, induced_mor_of_stalks_nat φ p,
  fmap_prevs_comp :=
    begin
      intros 𝓕₁ 𝓕₂ 𝓕₃ φ₁ φ₂,
      rw induced_mor_of_stalks_nat_compose,
    end,
  fmap_prevs_id :=
    begin
      intro 𝓕,
      rw induced_mor_of_stalks_nat_id,
    end,
}

end sheaf


import data.nat.basic

open classical

lemma all_zero : ∃ a b c : ℕ, a + b + c = 0 :=
begin
  use 0,
  use 0,
  use 0,
end

example : 1 = 1 :=
begin
  choose a b c h using all_zero,
  exact rfl,
end


universes u v

namespace state_t

variables {σ α : Type u}
variables {m : Type u → Type u}
variables [monad m]
variables [is_lawful_monad m]

open is_lawful_monad
lemma get_bind (s : σ) (f : σ → state_t σ m α)
: (get >>= f).run s = (f s).run s :=
by { simp [bind,state_t.bind,get,state_t.get,monad_state.lift,pure_bind,has_pure.pure,bind._match_1] }

end state_t


--

/-
This example demonstratea that when we are using `native_decide`,
we are also trusting the correctness of `implemented_by` annotations,
foreign functions (i.e., `[extern]` annotations), etc.
-/
def g (b : Bool) := false

/-
The following `implemented_by` is telling the compiler
"trust me, `g` does implement `f`"
which is clearly false in this example.
-/
@[implemented_by g]
def f (b : Bool) := b

theorem fConst (b : Bool) : f b = false :=
match b with
| true  =>
  /- The following `native_decide` is going to use `g` to evaluate `f`
     because of the `implemented_by` directive. -/
  have : (f true) = false := by native_decide
  this
| false => rfl

theorem trueEqFalse : true = false :=
have h₁ : f true = true  := rfl;
have h₂ : f true = false := fConst true;
Eq.trans h₁.symm h₂

/-
We managed to prove `False` using the unsound annotation `implemented_by` above.
-/
theorem unsound : False :=
Bool.noConfusion trueEqFalse

#print axioms unsound -- axiom 'Lean.ofReduceBool' is listed


/-
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.Pointed

/-!
# The category of bipointed types

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

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of bipointed types. -/
structure Bipointed : Type.{u + 1} :=
(X : Type.{u})
(to_prod : X × X)

namespace Bipointed

instance : has_coe_to_sort Bipointed Type* := ⟨X⟩

attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type*} (to_prod : X × X) : Bipointed := ⟨X, to_prod⟩

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

alias of ← _root_.prod.Bipointed

instance : inhabited Bipointed := ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext] protected structure hom (X Y : Bipointed.{u}) : Type u :=
(to_fun : X → Y)
(map_fst : to_fun X.to_prod.1 = Y.to_prod.1)
(map_snd : to_fun X.to_prod.2 = Y.to_prod.2)

namespace hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps] def id (X : Bipointed) : hom X X := ⟨id, rfl, rfl⟩

instance (X : Bipointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps] def comp {X Y Z : Bipointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_fst, g.map_fst],
  by rw [function.comp_apply, f.map_snd, g.map_snd]⟩

end hom

instance large_category : large_category Bipointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Bipointed :=
{ forget := { obj := Bipointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

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

/-- The equivalence between `Bipointed` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Bipointed ≌ Bipointed :=
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 Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def Bipointed_to_Pointed_fst : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.1⟩, map := λ X Y f, ⟨f.to_fun, f.map_fst⟩ }

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def Bipointed_to_Pointed_snd : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.2⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd⟩ }

@[simp] lemma Bipointed_to_Pointed_fst_comp_forget :
  Bipointed_to_Pointed_fst ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma Bipointed_to_Pointed_snd_comp_forget :
  Bipointed_to_Pointed_snd ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_fst :
  Bipointed.swap ⋙ Bipointed_to_Pointed_fst = Bipointed_to_Pointed_snd := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_snd :
  Bipointed.swap ⋙ Bipointed_to_Pointed_snd = Bipointed_to_Pointed_fst := rfl

/-- The functor from `Pointed` to `Bipointed` which bipoints the point. -/
def Pointed_to_Bipointed : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.point, X.point⟩, map := λ X Y f, ⟨f.to_fun, f.map_point, f.map_point⟩ }

/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def Pointed_to_Bipointed_fst : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, X.point, 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 `Bipointed` which adds a first point. -/
def Pointed_to_Bipointed_snd : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, none, X.point⟩,
  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_Bipointed_fst_comp_swap :
  Pointed_to_Bipointed_fst ⋙ Bipointed.swap = Pointed_to_Bipointed_snd := rfl

@[simp] lemma Pointed_to_Bipointed_snd_comp_swap :
  Pointed_to_Bipointed_snd ⋙ Bipointed.swap = Pointed_to_Bipointed_fst := rfl

/-- `Bipointed_to_Pointed_fst` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_fst :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_fst ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- `Bipointed_to_Pointed_snd` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_snd :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_snd ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_fst` and `Bipointed_to_Pointed_fst`.
-/
def Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Bipointed_fst ⊣ 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_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 } }

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_snd` and `Bipointed_to_Pointed_snd`.
-/
def Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Bipointed_snd ⊣ 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_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 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Group.abelian
import category_theory.limits.shapes.kernels

noncomputable theory

open category_theory
open category_theory.limits

/-!
Some small examples of using limits and colimits in `Ab`, the category of additive commutative
groups.
-/

example (G H : Ab) (f : G ⟶ H) : Ab := kernel f
example (G H : Ab) (f : G ⟶ H) [epi f] : kernel (cokernel.π f) ≅ H :=
as_iso (kernel.ι (cokernel.π f))

-- TODO no images yet...


/- Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl

Introduce CommRing -- the category of commutative rings.

Currently only the basic setup.
-/

import category_theory.instances.monoids
import category_theory.fully_faithful
import category_theory.adjunction
import data.mv_polynomial
import algebra.ring

universes u v

open category_theory

namespace category_theory.instances

/-- The category of rings. -/
@[reducible] def Ring : Type (u+1) := bundled ring

instance (x : Ring) : ring x := x.str

instance concrete_is_ring_hom : concrete_category @is_ring_hom :=
⟨by introsI α ia; apply_instance,
  by introsI α β γ ia ib ic f g hf hg; apply_instance⟩

instance Ring_hom_is_ring_hom {R S : Ring} (f : R ⟶ S) : is_ring_hom (f : R → S) := f.2

/-- The category of commutative rings. -/
@[reducible] def CommRing : Type (u+1) := bundled comm_ring

instance (x : CommRing) : comm_ring x := x.str

-- Here we don't use the `concrete` machinery,
-- because it would require introducing a useless synonym for `is_ring_hom`.
instance : category CommRing :=
{ hom := λ R S, { f : R → S // is_ring_hom f },
  id := λ R, ⟨ id, by resetI; apply_instance ⟩,
  comp := λ R S T g h, ⟨ h.1 ∘ g.1, begin haveI := g.2, haveI := h.2, apply_instance end ⟩ }

namespace CommRing
variables {R S T : CommRing.{u}}

@[simp] lemma id_val : subtype.val (𝟙 R) = id := rfl
@[simp] lemma comp_val (f : R ⟶ S) (g : S ⟶ T) :
  (f ≫ g).val = g.val ∘ f.val := rfl

instance hom_coe : has_coe_to_fun (R ⟶ S) :=
{ F := λ f, R → S,
  coe := λ f, f.1 }

@[simp] lemma hom_coe_app (f : R ⟶ S) (r : R) : f r = f.val r := rfl

instance hom_is_ring_hom (f : R ⟶ S) : is_ring_hom (f : R → S) := f.2

def Int : CommRing := ⟨ℤ, infer_instance⟩

def Int.cast {R : CommRing} : Int ⟶ R := { val := int.cast, property := by apply_instance }

def int.eq_cast' {R : Type u} [ring R] (f : int → R) [is_ring_hom f] : f = int.cast :=
funext $ int.eq_cast f (is_ring_hom.map_one f) (λ _ _, is_ring_hom.map_add f)

def Int.hom_unique {R : CommRing} : unique (Int ⟶ R) :=
{ default := Int.cast,
  uniq := λ f, subtype.ext.mpr $ funext $ int.eq_cast f f.2.map_one f.2.map_add }

/-- The forgetful functor commutative rings to Type. -/
def forget : CommRing.{u} ⥤ Type u :=
{ obj := λ R, R,
  map := λ _ _ f, f }

instance forget.faithful : faithful (forget) := {}

/-- The functor from commutative rings to rings. -/
def to_Ring : CommRing.{u} ⥤ Ring.{u} :=
{ obj := λ X, { α := X.1, str := by apply_instance },
  map := λ X Y f, ⟨ f, by apply_instance ⟩ }

instance to_Ring.faithful : faithful (to_Ring) := {}

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
def forget_to_CommMon : CommRing.{u} ⥤ CommMon.{u} :=
{ obj := λ X, { α := X.1, str := by apply_instance },
  map := λ X Y f, ⟨ f, by apply_instance ⟩ }

instance forget_to_CommMon.faithful : faithful (forget_to_CommMon) := {}

example : faithful (forget_to_CommMon ⋙ CommMon.forget_to_Mon) := by apply_instance

section
open mv_polynomial
local attribute [instance, priority 0] subtype.fintype set_fintype classical.prop_decidable

noncomputable def polynomial : Type u ⥤ CommRing.{u} :=
{ obj := λ α, ⟨mv_polynomial α ℤ, by apply_instance⟩,
  map := λ α β f, ⟨eval₂ C (X ∘ f), by apply_instance⟩,
  map_id' := λ α, subtype.ext.mpr $ funext $ eval₂_eta,
  map_comp' := λ α β γ f g, subtype.ext.mpr $ funext $ λ p,
  by apply mv_polynomial.induction_on p; intros;
    simp only [*, eval₂_add, eval₂_mul, eval₂_C, eval₂_X, comp_val,
      eq_self_iff_true, function.comp_app, types_comp] at * }

@[simp] lemma polynomial_obj_α {α : Type u} :
  (polynomial.obj α).α = mv_polynomial α ℤ := rfl

@[simp] lemma polynomial_map_val {α β : Type u} {f : α → β} :
  (CommRing.polynomial.map f).val = eval₂ C (X ∘ f) := rfl

noncomputable def adj : adjunction polynomial (forget : CommRing ⥤ Type u) :=
adjunction.mk_of_hom_equiv _ _
{ hom_equiv := λ α R,
  { to_fun := λ f, f ∘ X,
    inv_fun := λ f, ⟨eval₂ int.cast f, by apply_instance⟩,
    left_inv := λ f, subtype.ext.mpr $ funext $ λ p,
    begin
      have H0 := λ n, (congr (int.eq_cast' (f.val ∘ C)) (rfl : n = n)).symm,
      have H1 := λ p₁ p₂, (@is_ring_hom.map_add _ _ _ _ f.val f.2 p₁ p₂).symm,
      have H2 := λ p₁ p₂, (@is_ring_hom.map_mul _ _ _ _ f.val f.2 p₁ p₂).symm,
      apply mv_polynomial.induction_on p; intros;
      simp only [*, eval₂_add, eval₂_mul, eval₂_C, eval₂_X,
        eq_self_iff_true, function.comp_app, hom_coe_app] at *
    end,
    right_inv := by tidy },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, subtype.ext.mpr $ funext $ λ p,
  begin
    apply mv_polynomial.induction_on p; intros;
    simp only [*, eval₂_mul, eval₂_add, eval₂_C, eval₂_X,
      comp_val, equiv.coe_fn_symm_mk, hom_coe_app, polynomial_map_val,
      eq_self_iff_true, function.comp_app, add_right_inj, types_comp] at *
  end }

end

end CommRing

end category_theory.instances


open System

namespace Day1

def input : FilePath := "/home/fred/lean/aoc2022/input_01"

/-
PART 1:
The jungle must be too overgrown and difficult to navigate in vehicles or access from the air; the Elves' expedition traditionally goes on foot. As your boats approach land, the Elves begin taking inventory of their supplies. One important consideration is food - in particular, the number of Calories each Elf is carrying (your puzzle input).

The Elves take turns writing down the number of Calories contained by the various meals, snacks, rations, etc. that they've brought with them, one item per line. Each Elf separates their own inventory from the previous Elf's inventory (if any) by a blank line.

For example, suppose the Elves finish writing their items' Calories and end up with the following list:

1000
2000
3000

4000

5000
6000

7000
8000
9000

10000

This list represents the Calories of the food carried by five Elves:

    The first Elf is carrying food with 1000, 2000, and 3000 Calories, a total of 6000 Calories.
    The second Elf is carrying one food item with 4000 Calories.
    The third Elf is carrying food with 5000 and 6000 Calories, a total of 11000 Calories.
    The fourth Elf is carrying food with 7000, 8000, and 9000 Calories, a total of 24000 Calories.
    The fifth Elf is carrying one food item with 10000 Calories.

In case the Elves get hungry and need extra snacks, they need to know which Elf to ask: they'd like to know how many Calories are being carried by the Elf carrying the most Calories. In the example above, this is 24000 (carried by the fourth Elf).

Find the Elf carrying the most Calories. How many total Calories is that Elf carrying?
-/
def first_part : IO Nat := do
  let rawdata ← IO.FS.lines input
  let f : (Nat × Nat) → String → (Nat × Nat) :=
    fun (cur, best) s =>
      match s with
      | "" => (0, max cur best)
      | s' => (cur + s'.toNat!, best)
  let (cur, best) := Array.foldl f (0, 0) rawdata
  return max cur best

/-
PART 2:
By the time you calculate the answer to the Elves' question, they've already realized that the Elf carrying the most Calories of food might eventually run out of snacks.

To avoid this unacceptable situation, the Elves would instead like to know the total Calories carried by the top three Elves carrying the most Calories. That way, even if one of those Elves runs out of snacks, they still have two backups.

In the example above, the top three Elves are the fourth Elf (with 24000 Calories), then the third Elf (with 11000 Calories), then the fifth Elf (with 10000 Calories). The sum of the Calories carried by these three elves is 45000.

Find the top three Elves carrying the most Calories. How many Calories are those Elves carrying in total?
-/

def TopArray (α : Type _) [LT α] [DecidableRel (α:=α) (· < ·)] (_ : Nat) := Array α

namespace TopArray
variable {α : Type _} [LT α] [DecidableRel (α:=α) (· < ·)]

def insert {n : Nat} (l : TopArray α n) (x : α) : TopArray α n :=
((l.insertAt! l.size x).insertionSort (· > ·)).eraseIdx n

end TopArray

def second_part : IO Nat := do
  let rawdata ← IO.FS.lines input
  let f : (Nat × TopArray Nat 3) → String → (Nat × TopArray Nat 3) :=
    fun (cur, topthree) s =>
      match s with
      | "" => (0, topthree.insert cur)
      | s' => (cur + s'.toNat!, topthree)
  let (last, topthree) := Array.foldl f (0, #[0, 0, 0]) rawdata
  return (topthree.insert last).foldl (· + ·) 0

end Day1


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.sheaf
import category_theory.sites.cover_lifting
import category_theory.adjunction.fully_faithful

/-!
# Dense subsites

We define `cover_dense` functors into sites as functors such that there exists a covering sieve
that factors through images of the functor for each object in `D`.

We will primarily consider cover-dense functors that are also full, since this notion is in general
not well-behaved otherwise. Note that https://ncatlab.org/nlab/show/dense+sub-site indeed has a
weaker notion of cover-dense that loosens this requirement, but it would not have all the properties
we would need, and some sheafification would be needed for here and there.

## Main results

- `category_theory.cover_dense.presheaf_hom`: If `G : C ⥤ (D, K)` is full and cover-dense,
  then given any presheaf `ℱ` and sheaf `ℱ'` on `D`, and a morphism `α : G ⋙ ℱ ⟶ G ⋙ ℱ'`,
  we may glue them together to obtain a morphism of presheaves `ℱ ⟶ ℱ'`.
- `category_theory.cover_dense.sheaf_iso`: If `ℱ` above is a sheaf and `α` is an iso,
  then the result is also an iso.
- `category_theory.cover_dense.iso_of_restrict_iso`: If `G : C ⥤ (D, K)` is full and cover-dense,
  then given any sheaves `ℱ, ℱ'` on `D`, and a morphism `α : ℱ ⟶ ℱ'`, then `α` is an iso if
  `G ⋙ ℱ ⟶ G ⋙ ℱ'` is iso.
- `category_theory.cover_dense.Sheaf_equiv_of_cover_preserving_cover_lifting`:
  If `G : (C, J) ⥤ (D, K)` is fully-faithful, cover-lifting, cover-preserving, and cover-dense,
  then it will induce an equivalence of categories of sheaves valued in a complete category.

## References

* [Elephant]: *Sketches of an Elephant*, ℱ. T. Johnstone: C2.2.
* https://ncatlab.org/nlab/show/dense+sub-site
* https://ncatlab.org/nlab/show/comparison+lemma

-/

universes v u

namespace category_theory

variables {C : Type*} [category C] {D : Type*} [category D] {E : Type*} [category E]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology E}

/--
An auxiliary structure that witnesses the fact that `f` factors through an image object of `G`.
-/
@[nolint has_inhabited_instance]
structure presieve.cover_by_image_structure (G : C ⥤ D) {V U : D} (f : V ⟶ U) :=
(obj : C)
(lift : V ⟶ G.obj obj)
(map : G.obj obj ⟶ U)
(fac' : lift ≫ map = f . obviously)

restate_axiom presieve.cover_by_image_structure.fac'

attribute [simp, reassoc] presieve.cover_by_image_structure.fac

/--
For a functor `G : C ⥤ D`, and an object `U : D`, `presieve.cover_by_image G U` is the presieve
of `U` consisting of those arrows that factor through images of `G`.
-/
def presieve.cover_by_image (G : C ⥤ D) (U : D) : presieve U :=
λ Y f, nonempty (presieve.cover_by_image_structure G f)

/--
For a functor `G : C ⥤ D`, and an object `U : D`, `sieve.cover_by_image G U` is the sieve of `U`
consisting of those arrows that factor through images of `G`.
-/
def sieve.cover_by_image (G : C ⥤ D) (U : D) : sieve U :=
⟨presieve.cover_by_image G U,
  λ X Y f ⟨⟨Z, f₁, f₂, (e : _ = _)⟩⟩ g,
    ⟨⟨Z, g ≫ f₁, f₂, show (g ≫ f₁) ≫ f₂ = g ≫ f, by rw [category.assoc, ← e]⟩⟩⟩

lemma presieve.in_cover_by_image (G : C ⥤ D) {X : D} {Y : C} (f : G.obj Y ⟶ X) :
  presieve.cover_by_image G X f := ⟨⟨Y, 𝟙 _, f, by simp⟩⟩

/--
A functor `G : (C, J) ⥤ (D, K)` is called `cover_dense` if for each object in `D`,
  there exists a covering sieve in `D` that factors through images of `G`.

This definition can be found in https://ncatlab.org/nlab/show/dense+sub-site Definition 2.2.
-/
structure cover_dense (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(is_cover : ∀ (U : D), sieve.cover_by_image G U ∈ K U)

open presieve opposite

namespace cover_dense

variable {K}

variables {A : Type*} [category A] {G : C ⥤ D} (H : cover_dense K G)

-- this is not marked with `@[ext]` because `H` can not be inferred from the type
lemma ext (H : cover_dense K G) (ℱ : SheafOfTypes K) (X : D) {s t : ℱ.val.obj (op X)}
  (h : ∀ ⦃Y : C⦄ (f : G.obj Y ⟶ X), ℱ.val.map f.op s = ℱ.val.map f.op t) :
  s = t :=
begin
  apply (ℱ.property (sieve.cover_by_image G X) (H.is_cover X)).is_separated_for.ext,
  rintros Y _ ⟨Z, f₁, f₂, ⟨rfl⟩⟩,
  simp [h f₂]
end

/--
(Implementation). Given an hom between the pullbacks of two sheaves, we can whisker it with
`coyoneda` to obtain an hom between the pullbacks of the sheaves of maps from `X`.
-/
@[simps] def hom_over {ℱ : Dᵒᵖ ⥤ A} {ℱ' : Sheaf K A} (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) (X : A) :
  G.op ⋙ (ℱ ⋙ coyoneda.obj (op X)) ⟶ G.op ⋙ (sheaf_over ℱ' X).val :=
whisker_right α (coyoneda.obj (op X))

/--
(Implementation). Given an iso between the pullbacks of two sheaves, we can whisker it with
`coyoneda` to obtain an iso between the pullbacks of the sheaves of maps from `X`.
-/
@[simps] def iso_over {ℱ ℱ' : Sheaf K A} (α : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) (X : A) :
  G.op ⋙ (sheaf_over ℱ X).val ≅ G.op ⋙ (sheaf_over ℱ' X).val :=
iso_whisker_right α (coyoneda.obj (op X))

lemma sheaf_eq_amalgamation (ℱ : Sheaf K A) {X : A} {U : D} {T : sieve U} (hT)
  (x : family_of_elements _ T) (hx) (t) (h : x.is_amalgamation t) :
  t = (ℱ.property X T hT).amalgamate x hx :=
(ℱ.property X T hT).is_separated_for x t _ h ((ℱ.property X T hT).is_amalgamation hx)

include H
variable [full G]
namespace types
variables {ℱ : Dᵒᵖ ⥤ Type v} {ℱ' : SheafOfTypes.{v} K} (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val)

/--
(Implementation). Given a section of `ℱ` on `X`, we can obtain a family of elements valued in `ℱ'`
that is defined on a cover generated by the images of `G`. -/
@[simp, nolint unused_arguments] noncomputable
def pushforward_family {X} (x : ℱ.obj (op X)) :
  family_of_elements ℱ'.val (cover_by_image G X) := λ Y f hf,
ℱ'.val.map hf.some.lift.op $ α.app (op _) (ℱ.map hf.some.map.op x : _)

/-- (Implementation). The `pushforward_family` defined is compatible. -/
lemma pushforward_family_compatible {X} (x : ℱ.obj (op X)) :
  (pushforward_family H α x).compatible :=
begin
  intros Y₁ Y₂ Z g₁ g₂ f₁ f₂ h₁ h₂ e,
  apply H.ext,
  intros Y f,
  simp only [pushforward_family, ← functor_to_types.map_comp_apply, ← op_comp],
  change (ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _) _ =
    (ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _) _,
  rw ← G.image_preimage (f ≫ g₁ ≫ _),
  rw ← G.image_preimage (f ≫ g₂ ≫ _),
  erw ← α.naturality (G.preimage _).op,
  erw ← α.naturality (G.preimage _).op,
  refine congr_fun _ x,
  simp only [quiver.hom.unop_op, functor.comp_map, ← op_comp, ← category.assoc,
    functor.op_map, ← ℱ.map_comp, G.image_preimage],
  congr' 3,
  simp [e]
end

/-- (Implementation). The morphism `ℱ(X) ⟶ ℱ'(X)` given by gluing the `pushforward_family`. -/
noncomputable
def app_hom (X : D) : ℱ.obj (op X) ⟶ ℱ'.val.obj (op X) := λ x,
  (ℱ'.property _ (H.is_cover X)).amalgamate
    (pushforward_family H α x)
    (pushforward_family_compatible H α x)

@[simp] lemma pushforward_family_apply {X} (x : ℱ.obj (op X)) {Y : C} (f : G.obj Y ⟶ X) :
  pushforward_family H α x f (presieve.in_cover_by_image G f) = α.app (op Y) (ℱ.map f.op x) :=
begin
  unfold pushforward_family,
  refine congr_fun _ x,
  rw ← G.image_preimage (nonempty.some _ : presieve.cover_by_image_structure _ _).lift,
  change ℱ.map _ ≫ α.app (op _) ≫ ℱ'.val.map _ = ℱ.map f.op ≫ α.app (op Y),
  erw ← α.naturality (G.preimage _).op,
  simp only [← functor.map_comp, ← category.assoc, functor.comp_map, G.image_preimage,
     G.op_map, quiver.hom.unop_op, ← op_comp, presieve.cover_by_image_structure.fac],
end

@[simp] lemma app_hom_restrict {X : D} {Y : C} (f : op X ⟶ op (G.obj Y)) (x) :
  ℱ'.val.map f (app_hom H α X x) = α.app (op Y) (ℱ.map f x) :=
begin
  refine ((ℱ'.property _ (H.is_cover X)).valid_glue
    (pushforward_family_compatible H α x) f.unop (presieve.in_cover_by_image G f.unop)).trans _,
  apply pushforward_family_apply
end

@[simp] lemma app_hom_valid_glue {X : D} {Y : C} (f : op X ⟶ op (G.obj Y)) :
  app_hom H α X ≫ ℱ'.val.map f = ℱ.map f ≫ α.app (op Y) :=
by { ext, apply app_hom_restrict }

/--
(Implementation). The maps given in `app_iso` is inverse to each other and gives a `ℱ(X) ≅ ℱ'(X)`.
-/
@[simps] noncomputable
def app_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) (X : D) :
  ℱ.val.obj (op X) ≅ ℱ'.val.obj (op X) :=
{ hom := app_hom H i.hom X,
  inv := app_hom H i.inv X,
  hom_inv_id' := by { ext x, apply H.ext, intros Y f, simp },
  inv_hom_id' := by { ext x, apply H.ext, intros Y f, simp } }

/--
Given an natural transformation `G ⋙ ℱ ⟶ G ⋙ ℱ'` between presheaves of types, where `G` is full
and cover-dense, and `ℱ'` is a sheaf, we may obtain a natural transformation between sheaves.
-/
@[simps] noncomputable
def presheaf_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) : ℱ ⟶ ℱ'.val :=
{ app := λ X, app_hom H α (unop X), naturality' := λ X Y f,
  begin
    ext x,
    apply H.ext ℱ' (unop Y),
    intros Y' f',
    simp only [app_hom_restrict, types_comp_apply, ← functor_to_types.map_comp_apply],
    rw app_hom_restrict H α (f ≫ f'.op : op (unop X) ⟶ _)
  end }

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of types, where `G` is full and
cover-dense, and `ℱ, ℱ'` are sheaves, we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def presheaf_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) :
  ℱ.val ≅ ℱ'.val :=
nat_iso.of_components (λ X, app_iso H i (unop X)) (presheaf_hom H i.hom).naturality

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of types, where `G` is full and
cover-dense, and `ℱ, ℱ'` are sheaves, we may obtain a natural isomorphism between sheaves.
-/
@[simps] noncomputable
def sheaf_iso {ℱ ℱ' : SheafOfTypes.{v} K} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) : ℱ ≅ ℱ' :=
{ hom := (presheaf_iso H i).hom, inv := (presheaf_iso H i).inv,
  hom_inv_id' := (presheaf_iso H i).hom_inv_id, inv_hom_id' := (presheaf_iso H i).inv_hom_id }

end types
open types

variables {ℱ : Dᵒᵖ ⥤ A} {ℱ' : Sheaf K A}

/-- (Implementation). The sheaf map given in `types.sheaf_hom` is natural in terms of `X`. -/
@[simps] noncomputable
def sheaf_coyoneda_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  coyoneda ⋙ (whiskering_left Dᵒᵖ A Type*).obj ℱ ⟶
  coyoneda ⋙ (whiskering_left Dᵒᵖ A Type*).obj ℱ'.val :=
{ app := λ X, presheaf_hom H (hom_over α (unop X)), naturality' := λ X Y f,
  begin
    ext U x,
    change app_hom H (hom_over α (unop Y)) (unop U) (f.unop ≫ x) =
      f.unop ≫ app_hom H (hom_over α (unop X)) (unop U) x,
    symmetry,
    apply sheaf_eq_amalgamation,
    apply H.is_cover,
    intros Y' f' hf',
    change unop X ⟶ ℱ.obj (op (unop _)) at x,
    simp only [pushforward_family, functor.comp_map,
      coyoneda_obj_map, hom_over_app, category.assoc],
    congr' 1,
    conv_lhs { rw ← hf'.some.fac },
    simp only [← category.assoc, op_comp, functor.map_comp],
    congr' 1,
    refine (app_hom_restrict H (hom_over α (unop X)) hf'.some.map.op x).trans _,
    simp
  end }

/--
(Implementation). `sheaf_coyoneda_hom` but the order of the arguments of the functor are swapped.
-/
noncomputable
def sheaf_yoneda_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  ℱ ⋙ yoneda ⟶ ℱ'.val ⋙ yoneda :=
begin
  let α := sheaf_coyoneda_hom H α,
  refine { app := _, naturality' := _ },
  { intro U,
    refine { app := λ X, (α.app X).app U,
      naturality' := λ X Y f, by simpa using congr_app (α.naturality f) U } },
  { intros U V i,
    ext X x,
    exact congr_fun ((α.app X).naturality i) x },
end

/--
Given an natural transformation `G ⋙ ℱ ⟶ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ'` is a sheaf, we may obtain a natural transformation
between presheaves.
-/
noncomputable
def sheaf_hom (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  ℱ ⟶ ℱ'.val :=
let α' := sheaf_yoneda_hom H α in
  { app := λ X, yoneda.preimage (α'.app X),
    naturality' := λ X Y f, yoneda.map_injective (by simpa using α'.naturality f) }

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ', ℱ` are sheaves,
we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def presheaf_iso {ℱ ℱ' : Sheaf K A} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) :
  ℱ.val ≅ ℱ'.val :=
begin
  haveI : ∀ (X : Dᵒᵖ), is_iso ((sheaf_hom H i.hom).app X),
  { intro X,
    apply is_iso_of_reflects_iso _ yoneda,
    use (sheaf_yoneda_hom H i.inv).app X,
    split;
      ext x : 2;
      simp only [sheaf_hom, nat_trans.comp_app, nat_trans.id_app, functor.image_preimage],
      exact ((presheaf_iso H (iso_over i (unop x))).app X).hom_inv_id,
      exact ((presheaf_iso H (iso_over i (unop x))).app X).inv_hom_id,
    apply_instance },
  haveI : is_iso (sheaf_hom H i.hom) := by apply nat_iso.is_iso_of_is_iso_app,
  apply as_iso (sheaf_hom H i.hom),
end

/--
Given an natural isomorphism `G ⋙ ℱ ≅ G ⋙ ℱ'` between presheaves of arbitrary category,
where `G` is full and cover-dense, and `ℱ', ℱ` are sheaves,
we may obtain a natural isomorphism between presheaves.
-/
@[simps] noncomputable
def sheaf_iso {ℱ ℱ' : Sheaf K A} (i : G.op ⋙ ℱ.val ≅ G.op ⋙ ℱ'.val) : ℱ ≅ ℱ' :=
{ hom := (presheaf_iso H i).hom,
  inv := (presheaf_iso H i).inv,
  hom_inv_id' := (presheaf_iso H i).hom_inv_id,
  inv_hom_id' := (presheaf_iso H i).inv_hom_id }

/--
The constructed `sheaf_hom α` is equal to `α` when restricted onto `C`.
-/
lemma sheaf_hom_restrict_eq (α : G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) :
  whisker_left G.op (sheaf_hom H α) = α :=
begin
  ext X,
  apply yoneda.map_injective,
  ext U,
  erw yoneda.image_preimage,
  symmetry,
  change (show (ℱ'.val ⋙ coyoneda.obj (op (unop U))).obj (op (G.obj (unop X))), from _) = _,
  apply sheaf_eq_amalgamation ℱ' (H.is_cover _),
  intros Y f hf,
  conv_lhs { rw ← hf.some.fac },
  simp only [pushforward_family, functor.comp_map, yoneda_map_app,
    coyoneda_obj_map, op_comp, functor_to_types.map_comp_apply, hom_over_app, ← category.assoc],
  congr' 1,
  simp only [category.assoc],
  congr' 1,
  rw ← G.image_preimage hf.some.map,
  symmetry,
  apply α.naturality (G.preimage hf.some.map).op,
  apply_instance
end

/--
If the pullback map is obtained via whiskering,
then the result `sheaf_hom (whisker_left G.op α)` is equal to `α`.
-/
lemma sheaf_hom_eq (α : ℱ ⟶ ℱ'.val) : sheaf_hom H (whisker_left G.op α) = α :=
begin
  ext X,
  apply yoneda.map_injective,
  ext U,
  erw yoneda.image_preimage,
  symmetry,
  change (show (ℱ'.val ⋙ coyoneda.obj (op (unop U))).obj (op (unop X)), from _) = _,
  apply sheaf_eq_amalgamation ℱ' (H.is_cover _),
  intros Y f hf,
  conv_lhs { rw ← hf.some.fac },
  simp [-presieve.cover_by_image_structure.fac],
  erw α.naturality_assoc,
  refl,
  apply_instance
end

/--
A full and cover-dense functor `G` induces an equivalence between morphisms into a sheaf and
morphisms over the restrictions via `G`.
-/
noncomputable
def restrict_hom_equiv_hom : (G.op ⋙ ℱ ⟶ G.op ⋙ ℱ'.val) ≃ (ℱ ⟶ ℱ'.val) :=
{ to_fun := sheaf_hom H,
  inv_fun := whisker_left G.op,
  left_inv := sheaf_hom_restrict_eq H,
  right_inv := sheaf_hom_eq H }

/--
Given a full and cover-dense functor `G` and a natural transformation of sheaves `α : ℱ ⟶ ℱ'`,
if the pullback of `α` along `G` is iso, then `α` is also iso.
-/
lemma iso_of_restrict_iso {ℱ ℱ' : Sheaf K A} (α : ℱ ⟶ ℱ')
  (i : is_iso (whisker_left G.op α)) : is_iso α :=
begin
  convert is_iso.of_iso (sheaf_iso H (as_iso (whisker_left G.op α))),
  symmetry,
  apply sheaf_hom_eq
end

/-- A fully faithful cover-dense functor preserves compatible families. -/
lemma compatible_preserving [faithful G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ eq,
  apply H.ext,
  intros W i,
  simp only [← functor_to_types.map_comp_apply, ← op_comp],
  rw ← G.image_preimage (i ≫ f₁),
  rw ← G.image_preimage (i ≫ f₂),
  apply hx,
  apply G.map_injective,
  simp [eq]
end

noncomputable
instance sites.pullback.full [faithful G] (Hp : cover_preserving J K G) :
  full (sites.pullback A H.compatible_preserving Hp) :=
{ preimage := λ ℱ ℱ' α, H.sheaf_hom α,
  witness' := λ ℱ ℱ' α, H.sheaf_hom_restrict_eq α }

instance sites.pullback.faithful [faithful G] (Hp : cover_preserving J K G) :
  faithful (sites.pullback A H.compatible_preserving Hp) :=
{ map_injective' := λ ℱ ℱ' α β (eq : whisker_left G.op α = whisker_left G.op β),
  by rw [← H.sheaf_hom_eq α, ← H.sheaf_hom_eq β, eq] }

end cover_dense

end category_theory

namespace category_theory.cover_dense

open category_theory

variables {C : Type u} [small_category C] {D : Type u} [small_category D]
variables {G : C ⥤ D} [full G] [faithful G]
variables {J : grothendieck_topology C} {K : grothendieck_topology D}
variables {A : Type v} [category.{u} A] [limits.has_limits A]
variables (Hd : cover_dense K G) (Hp : cover_preserving J K G) (Hl : cover_lifting J K G)

include Hd Hp Hl

/--
Given a functor between small sites that is cover-dense, cover-preserving, and cover-lifting,
it induces an equivalence of category of sheaves valued in a complete category.
-/
@[simps functor inverse] noncomputable
def Sheaf_equiv_of_cover_preserving_cover_lifting : Sheaf J A ≌ Sheaf K A :=
begin
  symmetry,
  let α := sites.pullback_copullback_adjunction A Hp Hl Hd.compatible_preserving,
  haveI : ∀ (X : Sheaf J A), is_iso (α.counit.app X),
  { intro ℱ,
    apply_with (reflects_isomorphisms.reflects (Sheaf_to_presheaf J A)) { instances := ff },
    exact is_iso.of_iso ((@as_iso _ _ _ _ _ (Ran.reflective A G.op)).app ℱ.val) },
  haveI : is_iso α.counit := nat_iso.is_iso_of_is_iso_app _,
  exact
  { functor := sites.pullback A Hd.compatible_preserving Hp,
    inverse := sites.copullback A Hl,
    unit_iso := as_iso α.unit,
    counit_iso := as_iso α.counit,
    functor_unit_iso_comp' := λ ℱ, by convert α.left_triangle_components }
end

end category_theory.cover_dense


import Duper.RuleM
import Duper.MClause
import Duper.Clause
import Duper.Util.ProofReconstruction
import Duper.Selection

namespace Duper
open Lean
open Meta
open RuleM

initialize Lean.registerTraceClass `Rule.equalityFactoring

/-
  Notes on the equality_factoring_soundness proofs:
  1. s, t, u, and v should all have the same type (α) because if they didn't, then equalityFactoringWithAllConstraints would throw an error.
  2. The reason we require four soundness proofs is that from the literals s = t and u = v, we may have s unified with u, s unified with v,
     t unified with u, or t unified with v.
-/
theorem equality_factoring_soundness1 {α : Type} {s : α} {t : α} (v : α) (h : s = t) : t ≠ v ∨ s = v := by
  apply @Classical.byCases (s = v)
  . intro s_eq_v
    exact Or.intro_right _ s_eq_v
  . intro s_ne_v
    rw [← h]
    exact Or.intro_left _ s_ne_v

theorem equality_factoring_soundness2 {α : Type} {s : α} {t : α} (u : α) (h : s = t) : t ≠ u ∨ u = s := by
  apply @Classical.byCases (u = s)
  . intro u_eq_s
    exact Or.intro_right _ u_eq_s
  . intro u_ne_s
    rw [← h]
    exact Or.intro_left _ (Ne.symm u_ne_s)

theorem equality_factoring_soundness3 {α : Type} {s : α} {t : α} (v : α) (h : s = t) : s ≠ v ∨ t = v := by
  apply @Classical.byCases (t = v)
  . intro t_eq_v
    exact Or.intro_right _ t_eq_v
  . intro t_ne_v
    rw [h]
    exact Or.intro_left _ t_ne_v

theorem equality_factoring_soundness4 {α : Type} {s : α} {t : α} (u : α) (h : s = t) : s ≠ u ∨ u = t := by
  apply @Classical.byCases (u = t)
  . intro u_eq_t
    exact Or.intro_right _ u_eq_t
  . intro u_ne_t
    rw [h]
    exact Or.intro_left _ (Ne.symm u_ne_t)

def mkEqualityFactoringProof (i : Nat) (j : Nat) (litside_i : LitSide) (litside_j : LitSide) (premises : List Expr) (parents : List ProofParent)
  (transferExprs : Array Expr) (c : Clause) : MetaM Expr := do
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!
    let mut proofCases : Array Expr := Array.mkEmpty parentLits.size
    for k in [:parentLits.size] do
      let lit := parentLits[k]!
      if k == i then
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let proofCase ←
            match (litside_i, litside_j) with
            | (LitSide.lhs, LitSide.lhs) => Meta.mkAppM ``equality_factoring_soundness1 #[Lit.getOtherSide parentLits[j]! litside_j, h]
            | (LitSide.lhs, LitSide.rhs) => Meta.mkAppM ``equality_factoring_soundness2 #[Lit.getOtherSide parentLits[j]! litside_j, h]
            | (LitSide.rhs, LitSide.lhs) => Meta.mkAppM ``equality_factoring_soundness3 #[Lit.getOtherSide parentLits[j]! litside_j, h]
            | (LitSide.rhs, LitSide.rhs) => Meta.mkAppM ``equality_factoring_soundness4 #[Lit.getOtherSide parentLits[j]! litside_j, h]
          Meta.mkLambdaFVars #[h] $ ← orSubclause (cLits.map Lit.toExpr) 2 proofCase
        proofCases := proofCases.push proofCase
      else if k == j then
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let idx := c.lits.size - 1
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
        proofCases := proofCases.push proofCase
      else
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          let idx :=
            if k < j && k < i then k
            else if (i < k && k < j) || (j < k && k < i) then k - 1
            else k - 2
          Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) idx h
        proofCases := proofCases.push proofCase
    let r ← orCases (parentLits.map Lit.toExpr) proofCases
    Meta.mkLambdaFVars xs $ mkApp r appliedPremise

/--
  Attempts to perform equality factoring on clause c with c.lits[i] as the literal to be transformed subject to the following constraints:
  1. c.lits[i].litside_i can be unified with c.lits[j].litside_j
  2. c.lits[i].litside_i is not less than c.lits[i].(LitSide.toggleSide litside_i) by the ground reduction ordering after the unification from (1)
  3. c.lits[i] is maximal and nothing is selected

  If any of these constraints fail to hold, then equalityFactoringWithAllConstraints should not do anything
-/
def equalityFactoringWithAllConstraints (given : Clause) (c : MClause) (i : Nat) (j : Nat) (litside_i : LitSide) (litside_j : LitSide) : RuleM ClauseStream :=
  withoutModifyingMCtx $ do
    let lit_i := c.lits[i]!
    let lit_j := c.lits[j]!
    let loaded ← getLoadedClauses
    let ug ← unifierGenerator #[(Lit.getSide lit_i litside_i, Lit.getSide lit_j litside_j)]
    let yC := do
      setLoadedClauses loaded
      match ← compare (Lit.getSide lit_i litside_i) (Lit.getOtherSide lit_i litside_i) with
      | Comparison.LessThan => return none
      | _ =>
        if (getSelections c).isEmpty ∧ (← c.isMaximalLit (← getOrder) i) then
          let new_lit : Lit :=
            { sign := false,
              lvl := lit_i.lvl -- lit_i.lvl = lit_j.lvl
              ty := lit_i.ty -- lit_i.ty = lit_j.ty
              lhs := Lit.getOtherSide lit_i litside_i
              rhs := Lit.getOtherSide lit_j litside_j
            }
          let modified_clause :=
            if (j < i) then -- erase i first so that c.lits[j] is still at the same index after the erasure
              ((c.eraseLit i).eraseLit j).appendLits #[new_lit, c.lits[j]!]
            else -- i < j because i cannot equal j
              ((c.eraseLit j).eraseLit i).appendLits #[new_lit, c.lits[j]!]
          trace[Rule.equalityFactoring] "Successfully calling equality factoring on {c.lits} to yield {modified_clause.lits}"
          some <$> yieldClause modified_clause "equality factoring" (mkProof := some (mkEqualityFactoringProof i j litside_i litside_j))
        else
          return none
    return ClauseStream.mk ug given yC "equality factoring"

/--
  Attempts to perform equality factoring with c.lits[i] as the literal to be transformed
-/
def equalityFactoringAtLit (given : Clause) (c : MClause) (i : Nat) (j : Nat) : RuleM (Array ClauseStream) := do
  /-
  Note: In the Schulz paper, it states that a side condition for EqualityFactoring is that if:
  1. s and t are the terms in c.lits[i]
  2. u and v are the terms in c.lits[j]
  3. σ = mgu(s, u)
  Then σ(s) can't be less than σ(t) by the ground reduction ordering.

  Technically, the only way to check whether this is the case is to try unifying s and u for every possible combination of s and u where
  s ∈ {c.lits[i].lhs, c.lits[i].rhs} and u ∈ {c.lits[j].lhs, c.lits[j].rhs}, and then confirming whether σ(s) is greater than or equal to
  σ(t) by the ground reduction ordering.

  However, unification is expensive, and we have the convenient property that if s < t, then σ(s) < σ(t) for all σ. So in order to successfully
  carry out the inference, we will still have to check whether σ(s) < σ(t) after the unification. But in some instances, we can know that the
  inference cannot be performed for certain choices of s ∈ {c.lits[i].lhs, c.lits[i].rhs} if we can see before unification that s < t. For
  instance, if c.lits[i].lhs < c.lits[i].rhs before unification, σ(c.lits[i].lhs) < σ(c.lits[i].rhs) after unification, so we know the inference
  will be excluded regardless, and so we don't need to bother attempting to call equalityFactoringWithAllConstraints with litside_i = LitSide.lhs.

  All this to say, though its counterintuitive, it is intentional that c.lits[i].lhs and c.lits[i].rhs are compared before unification in this function
  and after unification in equalityFactoringWithAllConstraints
  -/
  match ← compare c.lits[i]!.lhs c.lits[i]!.rhs with
  | Comparison.LessThan =>
    trace[Rule.equalityFactoring] "{c.lits[i]!.lhs} < {c.lits[i]!.rhs} by the ground reduction ordering"
    let str1 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].lhs
    let str2 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].rhs
    return #[str1, str2]
  | Comparison.GreaterThan =>
    trace[Rule.equalityFactoring] "{c.lits[i]!.lhs} > {c.lits[i]!.rhs} by the ground reduction ordering"
    let str1 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].lhs
    let str2 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].rhs
    return #[str1, str2]
  | _ => -- If the Comparison is Equal or Incomparable, we unfortunately have to just try all possibilities
    trace[Rule.equalityFactoring] "{c.lits[i]!.lhs} equal to or incomparable to {c.lits[i]!.rhs} by the ground reduction ordering"
    let str1 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].lhs
    let str2 ← equalityFactoringWithAllConstraints given c i j LitSide.rhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].rhs with c.lits[j].rhs
    let str3 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.lhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].lhs
    let str4 ← equalityFactoringWithAllConstraints given c i j LitSide.lhs LitSide.rhs -- Attempt to perform inference unifying c.lits[i].lhs with c.lits[j].rhs
    return #[str1, str2, str3, str4]

def equalityFactoring (given : Clause) (c : MClause) (cNum : Nat) : RuleM (Array ClauseStream) := do
  trace[Rule.equalityFactoring] "EqFact inferences with {c.lits}"
  let mut streams := #[]
  for i in [:c.lits.size] do
    if(c.lits[i]!.sign) then
      for j in [i+1:c.lits.size] do -- Since we call equalityFactoringAtLit c i j and equalityFactoringAtLit c j i, we can always have j > i
        if(c.lits[j]!.sign) then
          -- Attempt to perform equalityFactoring with c.lits[i] as the literal to be transformed
          trace[Rule.equalityFactoring] "Attempting to call equalityFactoring on {c.lits} using {c.lits[i]!} and {c.lits[j]!}"
          let str ← equalityFactoringAtLit given c i j
          streams := streams.append str
          -- Attempt to perform equalityFactoring with c.lits[j] as the literal to be transformed
          let str ← equalityFactoringAtLit given c j i
          streams := streams.append str
  return streams

end Duper