/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.affine
import ring_theory.local_properties

/-!

# Properties of morphisms from properties of ring homs.

We provide the basic framework for talking about properties of morphisms that come from properties
of ring homs. For `P` a property of ring homs, we have two ways of defining a property of scheme
morphisms:

Let `f : X ⟶ Y`,
- `target_affine_locally (affine_and P)`: the preimage of an affine open `U = Spec A` is affine
  (`= Spec B`) and `A ⟶ B` satisfies `P`. (TODO)
- `affine_locally P`: For each pair of affine open `U = Spec A ⊆ X` and `V = Spec B ⊆ f ⁻¹' U`,
  the ring hom `A ⟶ B` satisfies `P`.

For these notions to be well defined, we require `P` be a sufficient local property. For the former,
`P` should be local on the source (`ring_hom.respects_iso P`, `ring_hom.localization_preserves P`,
`ring_hom.of_localization_span`), and `target_affine_locally (affine_and P)` will be local on
the target. (TODO)

For the latter `P` should be local on the target (`ring_hom.property_is_local P`), and
`affine_locally P` will be local on both the source and the target.

Further more, these properties are stable under compositions (resp. base change) if `P` is. (TODO)

-/

universe u

open category_theory opposite topological_space category_theory.limits algebraic_geometry

variable (P : ∀ {R S : Type u} [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)

namespace ring_hom

include P

variable {P}

lemma respects_iso.basic_open_iff (hP : respects_iso @P) {X Y : Scheme}
  [is_affine X] [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (opposite.op ⊤)) :
  P (Scheme.Γ.map (f ∣_ Y.basic_open r).op) ↔
  P (@is_localization.away.map (Y.presheaf.obj (opposite.op ⊤)) _
      (Y.presheaf.obj (opposite.op $ Y.basic_open r)) _ _
      (X.presheaf.obj (opposite.op ⊤)) _ (X.presheaf.obj
      (opposite.op $ X.basic_open (Scheme.Γ.map f.op r))) _ _ (Scheme.Γ.map f.op) r _ _) :=
begin
  rw [Γ_map_morphism_restrict, hP.cancel_left_is_iso, hP.cancel_right_is_iso,
    ← (hP.cancel_right_is_iso (f.val.c.app (opposite.op (Y.basic_open r))) (X.presheaf.map
      (eq_to_hom (Scheme.preimage_basic_open f r).symm).op)), ← eq_iff_iff],
  congr,
  delta is_localization.away.map,
  refine is_localization.ring_hom_ext (submonoid.powers r) _,
  convert (is_localization.map_comp _).symm using 1,
  change Y.presheaf.map _ ≫ _ = _ ≫ X.presheaf.map _,
  rw f.val.c.naturality_assoc,
  erw ← X.presheaf.map_comp,
  congr,
end

lemma respects_iso.basic_open_iff_localization (hP : respects_iso @P)
  {X Y : Scheme} [is_affine X] [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (opposite.op ⊤)) :
  P (Scheme.Γ.map (f ∣_ Y.basic_open r).op) ↔
  P (localization.away_map (Scheme.Γ.map f.op) r) :=
(hP.basic_open_iff _ _).trans (hP.is_localization_away_iff _ _ _ _).symm

lemma respects_iso.of_restrict_morphism_restrict_iff (hP : ring_hom.respects_iso @P)
  {X Y : Scheme} [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (opposite.op ⊤))
  (U : opens X.carrier) (hU : is_affine_open U) {V : opens _}
  (e : V = (opens.map (X.of_restrict ((opens.map f.1.base).obj _).open_embedding).1.base).obj U) :
  P (Scheme.Γ.map ((X.restrict ((opens.map f.1.base).obj _).open_embedding).of_restrict
    V.open_embedding ≫ f ∣_ Y.basic_open r).op) ↔
    P (localization.away_map (Scheme.Γ.map (X.of_restrict U.open_embedding ≫ f).op) r) :=
begin
  subst e,
  convert (hP.is_localization_away_iff _ _ _ _).symm,
  rotate,
  { apply_instance },
  { apply ring_hom.to_algebra,
    refine X.presheaf.map
      (@hom_of_le _ _ ((is_open_map.functor _).obj _) ((is_open_map.functor _).obj _) _).op,
    rw [opens.le_def],
    dsimp,
    change coe '' (coe '' set.univ) ⊆ coe '' set.univ,
    rw [subtype.coe_image_univ, subtype.coe_image_univ],
    exact set.image_preimage_subset _ _ },
  { exact algebraic_geometry.Γ_restrict_is_localization Y r },
  { rw ← U.open_embedding_obj_top at hU,
    dsimp [Scheme.Γ_obj_op, Scheme.Γ_map_op, Scheme.restrict],
    apply algebraic_geometry.is_localization_of_eq_basic_open _ hU,
    rw [opens.open_embedding_obj_top, opens.functor_obj_map_obj],
    convert (X.basic_open_res (Scheme.Γ.map f.op r) (hom_of_le le_top).op).symm using 1,
    rw [opens.open_embedding_obj_top, opens.open_embedding_obj_top, inf_comm,
      Scheme.Γ_map_op, ← Scheme.preimage_basic_open] },
  { apply is_localization.ring_hom_ext (submonoid.powers r) _,
    swap, { exact algebraic_geometry.Γ_restrict_is_localization Y r },
    rw [is_localization.away.map, is_localization.map_comp, ring_hom.algebra_map_to_algebra,
      ring_hom.algebra_map_to_algebra, op_comp, functor.map_comp, op_comp, functor.map_comp],
    refine (@category.assoc CommRing _ _ _ _ _ _ _ _).symm.trans _,
    refine eq.trans _ (@category.assoc CommRing _ _ _ _ _ _ _ _),
    dsimp only [Scheme.Γ_map, quiver.hom.unop_op],
    rw [morphism_restrict_c_app, category.assoc, category.assoc, category.assoc],
    erw [f.1.c.naturality_assoc, ← X.presheaf.map_comp, ← X.presheaf.map_comp,
      ← X.presheaf.map_comp],
    congr },
end

lemma stable_under_base_change.Γ_pullback_fst
  (hP : stable_under_base_change @P) (hP' : respects_iso @P) {X Y S : Scheme}
  [is_affine X] [is_affine Y] [is_affine S]
  (f : X ⟶ S) (g : Y ⟶ S) (H : P (Scheme.Γ.map g.op)) :
    P (Scheme.Γ.map (pullback.fst : pullback f g ⟶ _).op) :=
begin
  rw [← preserves_pullback.iso_inv_fst AffineScheme.forget_to_Scheme
    (AffineScheme.of_hom f) (AffineScheme.of_hom g), op_comp, functor.map_comp,
    hP'.cancel_right_is_iso, AffineScheme.forget_to_Scheme_map],
  have := _root_.congr_arg quiver.hom.unop (preserves_pullback.iso_hom_fst AffineScheme.Γ.right_op
    (AffineScheme.of_hom f) (AffineScheme.of_hom g)),
  simp only [quiver.hom.unop_op, functor.right_op_map, unop_comp] at this,
  delta AffineScheme.Γ at this,
  simp only [quiver.hom.unop_op, functor.comp_map, AffineScheme.forget_to_Scheme_map,
    functor.op_map] at this,
  rw [← this, hP'.cancel_right_is_iso,
    ← pushout_iso_unop_pullback_inl_hom (quiver.hom.unop _) (quiver.hom.unop _),
    hP'.cancel_right_is_iso],
  exact hP.pushout_inl _ hP' _ _ H
end

end ring_hom

namespace algebraic_geometry

/-- For `P` a property of ring homomorphisms, `source_affine_locally P` holds for `f : X ⟶ Y`
whenever `P` holds for the restriction of `f` on every affine open subset of `X`. -/
def source_affine_locally : affine_target_morphism_property :=
λ X Y f hY, ∀ (U : X.affine_opens), P (Scheme.Γ.map (X.of_restrict U.1.open_embedding ≫ f).op)

/-- For `P` a property of ring homomorphisms, `affine_locally P` holds for `f : X ⟶ Y` if for each
affine open `U = Spec A ⊆ Y` and `V = Spec B ⊆ f ⁻¹' U`, the ring hom `A ⟶ B` satisfies `P`.
Also see `affine_locally_iff_affine_opens_le`. -/
abbreviation affine_locally : morphism_property Scheme :=
target_affine_locally (source_affine_locally @P)

variable {P}

lemma source_affine_locally_respects_iso (h₁ : ring_hom.respects_iso @P) :
  (source_affine_locally @P).to_property.respects_iso :=
begin
  apply affine_target_morphism_property.respects_iso_mk,
  { introv H U,
    rw [← h₁.cancel_right_is_iso _ (Scheme.Γ.map (Scheme.restrict_map_iso e.inv U.1).hom.op),
      ← functor.map_comp, ← op_comp],
    convert H ⟨_, U.prop.map_is_iso e.inv⟩ using 3,
    rw [is_open_immersion.iso_of_range_eq_hom, is_open_immersion.lift_fac_assoc,
      category.assoc, e.inv_hom_id_assoc],
    refl },
  { introv H U,
    rw [← category.assoc, op_comp, functor.map_comp, h₁.cancel_left_is_iso],
    exact H U }
end

lemma affine_locally_mono
  (P₁ P₂ : ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)
  (H : ∀ {R S : Type u} [comm_ring R] [comm_ring S], by exactI ∀ (f : R →+* S), P₁ f → P₂ f) :
  affine_locally P₁ ≤ affine_locally P₂ :=
begin
  refine target_affine_locally_mono _,
  intros X Y f hY hf U,
  exact H _ (hf _),
end
lemma affine_locally_respects_iso (h : ring_hom.respects_iso @P) :
  (affine_locally @P).respects_iso :=
target_affine_locally_respects_iso (source_affine_locally_respects_iso h)

lemma affine_locally_iff_affine_opens_le
  (hP : ring_hom.respects_iso @P) {X Y : Scheme} (f : X ⟶ Y) :
  affine_locally @P f ↔
  (∀ (U : Y.affine_opens) (V : X.affine_opens) (e : V.1 ≤ (opens.map f.1.base).obj U.1),
    P (f.app_le e)) :=
begin
  apply forall_congr,
  intro U,
  delta source_affine_locally,
  simp_rw [op_comp, Scheme.Γ.map_comp, Γ_map_morphism_restrict, category.assoc, Scheme.Γ_map_op,
    hP.cancel_left_is_iso],
  split,
  { intros H V e,
    let U' := (opens.map f.val.base).obj U.1,
    have e' : U'.open_embedding.is_open_map.functor.obj ((opens.map U'.inclusion).obj V.1) = V.1,
    { ext1, refine set.image_preimage_eq_inter_range.trans (set.inter_eq_left_iff_subset.mpr _),
      convert e, exact subtype.range_coe },
    have := H ⟨(opens.map (X.of_restrict (U'.open_embedding)).1.base).obj V.1, _⟩,
    erw ← X.presheaf.map_comp at this,
    rw [← hP.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _)), category.assoc,
      ← X.presheaf.map_comp],
    convert this using 1,
    { dsimp only [functor.op, unop_op], rw opens.open_embedding_obj_top, congr' 1, exact e'.symm },
    { apply_instance },
    { apply (is_affine_open_iff_of_is_open_immersion (X.of_restrict _) _).mp,
      convert V.2,
      apply_instance } },
  { intros H V,
    specialize H ⟨_, V.2.image_is_open_immersion (X.of_restrict _)⟩ (subtype.coe_image_subset _ _),
    erw ← X.presheaf.map_comp,
    rw [← hP.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _)), category.assoc,
      ← X.presheaf.map_comp],
    convert H,
    { dsimp only [functor.op, unop_op], rw opens.open_embedding_obj_top, refl },
    { apply_instance } }
end

lemma Scheme_restrict_basic_open_of_localization_preserves
  (h₁ : ring_hom.respects_iso @P)
  (h₂ : ring_hom.localization_preserves @P)
  {X Y : Scheme} [is_affine Y] (f : X ⟶ Y) (r : Y.presheaf.obj (op ⊤))
  (H : source_affine_locally @P f)
  (U : (X.restrict ((opens.map f.1.base).obj $ Y.basic_open r).open_embedding).affine_opens) :
  P (Scheme.Γ.map
    ((X.restrict ((opens.map f.1.base).obj $ Y.basic_open r).open_embedding).of_restrict
      U.1.open_embedding ≫ f ∣_ Y.basic_open r).op) :=
begin
  specialize H ⟨_, U.2.image_is_open_immersion (X.of_restrict _)⟩,
  convert (h₁.of_restrict_morphism_restrict_iff _ _ _ _ _).mpr _ using 1,
  swap 5,
  { exact h₂.away r H },
  { apply_instance },
  { exact U.2.image_is_open_immersion _},
  { ext1, exact (set.preimage_image_eq _ subtype.coe_injective).symm }
end

lemma source_affine_locally_is_local
  (h₁ : ring_hom.respects_iso @P)
  (h₂ : ring_hom.localization_preserves @P)
  (h₃ : ring_hom.of_localization_span @P) : (source_affine_locally @P).is_local :=
begin
  constructor,
  { exact source_affine_locally_respects_iso h₁ },
  { introv H U,
    apply Scheme_restrict_basic_open_of_localization_preserves h₁ h₂; assumption },
  { introv hs hs' U,
    resetI,
    apply h₃ _ _ hs,
    intro r,
    have := hs' r ⟨(opens.map (X.of_restrict _).1.base).obj U.1, _⟩,
    rwa h₁.of_restrict_morphism_restrict_iff at this,
    { exact U.2 },
    { refl },
    { apply_instance },
    { suffices : ∀ (V = (opens.map f.val.base).obj (Y.basic_open r.val)),
        is_affine_open ((opens.map (X.of_restrict V.open_embedding).1.base).obj U.1),
      { exact this _ rfl, },
      intros V hV,
      rw Scheme.preimage_basic_open at hV,
      subst hV,
      exact U.2.map_restrict_basic_open (Scheme.Γ.map f.op r.1) } }
end

variables {P} (hP : ring_hom.property_is_local @P)

lemma source_affine_locally_of_source_open_cover_aux
  (h₁ : ring_hom.respects_iso @P)
  (h₃ : ring_hom.of_localization_span_target @P)
  {X Y : Scheme} (f : X ⟶ Y) (U : X.affine_opens)
  (s : set (X.presheaf.obj (op U.1))) (hs : ideal.span s = ⊤)
  (hs' : ∀ (r : s), P (Scheme.Γ.map (X.of_restrict (X.basic_open r.1).open_embedding ≫ f).op)) :
    P (Scheme.Γ.map (X.of_restrict U.1.open_embedding ≫ f).op) :=
begin
  apply_fun ideal.map (X.presheaf.map (eq_to_hom U.1.open_embedding_obj_top).op) at hs,
  rw [ideal.map_span, ideal.map_top] at hs,
  apply h₃ _ _ hs,
  rintro ⟨s, r, hr, hs⟩,
  have := (@@localization.alg_equiv _ _ _ _ _ (@@algebraic_geometry.Γ_restrict_is_localization
    _ U.2 s)).to_ring_equiv.to_CommRing_iso,
  refine (h₁.cancel_right_is_iso _ (@@localization.alg_equiv _ _ _ _ _
    (@@algebraic_geometry.Γ_restrict_is_localization _ U.2 s))
      .to_ring_equiv.to_CommRing_iso.hom).mp _,
  subst hs,
  rw [CommRing.comp_eq_ring_hom_comp, ← ring_hom.comp_assoc],
  erw [is_localization.map_comp, ring_hom.comp_id],
  rw [ring_hom.algebra_map_to_algebra, op_comp, functor.map_comp, ← CommRing.comp_eq_ring_hom_comp,
    Scheme.Γ_map_op, Scheme.Γ_map_op, Scheme.Γ_map_op, category.assoc],
  erw ← X.presheaf.map_comp,
  rw [← h₁.cancel_right_is_iso _ (X.presheaf.map (eq_to_hom _))],
  convert hs' ⟨r, hr⟩ using 1,
  { erw category.assoc, rw [← X.presheaf.map_comp, op_comp, Scheme.Γ.map_comp,
    Scheme.Γ_map_op, Scheme.Γ_map_op], congr },
  { dsimp [functor.op],
    conv_lhs { rw opens.open_embedding_obj_top },
    conv_rhs { rw opens.open_embedding_obj_top },
    erw Scheme.image_basic_open (X.of_restrict U.1.open_embedding),
    erw PresheafedSpace.is_open_immersion.of_restrict_inv_app_apply,
    rw Scheme.basic_open_res_eq },
  { apply_instance }
end

lemma is_open_immersion_comp_of_source_affine_locally (h₁ : ring_hom.respects_iso @P)
  {X Y Z : Scheme} [is_affine X] [is_affine Z] (f : X ⟶ Y) [is_open_immersion f] (g : Y ⟶ Z)
  (h₂ : source_affine_locally @P g) :
  P (Scheme.Γ.map (f ≫ g).op) :=
begin
  rw [← h₁.cancel_right_is_iso _ (Scheme.Γ.map (is_open_immersion.iso_of_range_eq
    (Y.of_restrict _) f _).hom.op), ← functor.map_comp, ← op_comp],
  convert h₂ ⟨_, range_is_affine_open_of_open_immersion f⟩ using 3,
  { rw [is_open_immersion.iso_of_range_eq_hom, is_open_immersion.lift_fac_assoc] },
  { apply_instance },
  { exact subtype.range_coe },
  { apply_instance }
end

end algebraic_geometry

open algebraic_geometry

namespace ring_hom.property_is_local

variables {P} (hP : ring_hom.property_is_local @P)

include hP

lemma source_affine_locally_of_source_open_cover
  {X Y : Scheme} (f : X ⟶ Y) [is_affine Y]
  (𝒰 : X.open_cover) [∀ i, is_affine (𝒰.obj i)] (H : ∀ i, P (Scheme.Γ.map (𝒰.map i ≫ f).op)) :
  source_affine_locally @P f :=
begin
  let S := λ i, (⟨⟨set.range (𝒰.map i).1.base, (𝒰.is_open i).base_open.open_range⟩,
    range_is_affine_open_of_open_immersion (𝒰.map i)⟩ : X.affine_opens),
  intros U,
  apply of_affine_open_cover U,
  swap 5, { exact set.range S },
  { intros U r H,
    convert hP.stable_under_composition _ _ H _ using 1,
    swap,
    { refine X.presheaf.map
        (@hom_of_le _ _ ((is_open_map.functor _).obj _) ((is_open_map.functor _).obj _) _).op,
      rw [unop_op, unop_op, opens.open_embedding_obj_top, opens.open_embedding_obj_top],
      exact X.basic_open_le _ },
    { rw [op_comp, op_comp, functor.map_comp, functor.map_comp],
      refine (eq.trans _ (category.assoc _ _ _).symm : _),
      congr' 1,
      refine eq.trans _ (X.presheaf.map_comp _ _),
      change X.presheaf.map _ = _,
      congr },
    convert hP.holds_for_localization_away _
      (X.presheaf.map (eq_to_hom U.1.open_embedding_obj_top).op r),
    { exact (ring_hom.algebra_map_to_algebra _).symm },
    { dsimp [Scheme.Γ],
      have := U.2,
      rw ← U.1.open_embedding_obj_top at this,
      convert is_localization_basic_open this _ using 6;
        rw opens.open_embedding_obj_top; exact (Scheme.basic_open_res_eq _ _ _).symm } },
  { introv hs hs',
    exact source_affine_locally_of_source_open_cover_aux hP.respects_iso hP.2 _ _ _ hs hs' },
  { rw set.eq_univ_iff_forall,
    intro x,
    rw set.mem_Union,
    exact ⟨⟨_, 𝒰.f x, rfl⟩, 𝒰.covers x⟩ },
  { rintro ⟨_, i, rfl⟩,
    specialize H i,
    rw ← hP.respects_iso.cancel_right_is_iso _ (Scheme.Γ.map (is_open_immersion.iso_of_range_eq
      (𝒰.map i) (X.of_restrict (S i).1.open_embedding) subtype.range_coe.symm).inv.op) at H,
    rwa [← Scheme.Γ.map_comp, ← op_comp, is_open_immersion.iso_of_range_eq_inv,
      is_open_immersion.lift_fac_assoc] at H }
end

lemma affine_open_cover_tfae {X Y : Scheme.{u}}
  [is_affine Y] (f : X ⟶ Y) :
  tfae [source_affine_locally @P f,
    ∃ (𝒰 : Scheme.open_cover.{u} X) [∀ i, is_affine (𝒰.obj i)],
      ∀ (i : 𝒰.J), P (Scheme.Γ.map (𝒰.map i ≫ f).op),
    ∀ (𝒰 : Scheme.open_cover.{u} X) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      P (Scheme.Γ.map (𝒰.map i ≫ f).op),
    ∀ {U : Scheme} (g : U ⟶ X) [is_affine U] [is_open_immersion g],
      P (Scheme.Γ.map (g ≫ f).op)] :=
begin
  tfae_have : 1 → 4,
  { intros H U g _ hg,
    resetI,
    specialize H ⟨⟨_, hg.base_open.open_range⟩,
      range_is_affine_open_of_open_immersion g⟩,
    rw [← hP.respects_iso.cancel_right_is_iso _ (Scheme.Γ.map (is_open_immersion.iso_of_range_eq
      g (X.of_restrict (opens.open_embedding ⟨_, hg.base_open.open_range⟩))
      subtype.range_coe.symm).hom.op), ← Scheme.Γ.map_comp, ← op_comp,
      is_open_immersion.iso_of_range_eq_hom] at H,
    erw is_open_immersion.lift_fac_assoc at H,
    exact H },
  tfae_have : 4 → 3,
  { intros H 𝒰 _ i, resetI, apply H },
  tfae_have : 3 → 2,
  { intro H, refine ⟨X.affine_cover, infer_instance, H _⟩ },
  tfae_have : 2 → 1,
  { rintro ⟨𝒰, _, h𝒰⟩,
    exactI hP.source_affine_locally_of_source_open_cover f 𝒰 h𝒰 },
  tfae_finish
end

lemma open_cover_tfae {X Y : Scheme.{u}} [is_affine Y] (f : X ⟶ Y) :
  tfae [source_affine_locally @P f,
    ∃ (𝒰 : Scheme.open_cover.{u} X), ∀ (i : 𝒰.J), source_affine_locally @P (𝒰.map i ≫ f),
    ∀ (𝒰 : Scheme.open_cover.{u} X) (i : 𝒰.J), source_affine_locally @P (𝒰.map i ≫ f),
    ∀ {U : Scheme} (g : U ⟶ X) [is_open_immersion g], source_affine_locally @P (g ≫ f)] :=
begin
  tfae_have : 1 → 4,
  { intros H U g hg V,
    resetI,
    rw (hP.affine_open_cover_tfae f).out 0 3 at H,
    haveI : is_affine _ := V.2,
    rw ← category.assoc,
    apply H },
  tfae_have : 4 → 3,
  { intros H 𝒰 _ i, resetI, apply H },
  tfae_have : 3 → 2,
  { intro H, refine ⟨X.affine_cover, H _⟩ },
  tfae_have : 2 → 1,
  { rintro ⟨𝒰, h𝒰⟩,
    rw (hP.affine_open_cover_tfae f).out 0 1,
    refine ⟨𝒰.bind (λ _, Scheme.affine_cover _), _, _⟩,
    { intro i, dsimp, apply_instance },
    { intro i,
      specialize h𝒰 i.1,
      rw (hP.affine_open_cover_tfae (𝒰.map i.fst ≫ f)).out 0 3 at h𝒰,
      erw category.assoc,
      apply @@h𝒰 _ (show _, from _),
      dsimp, apply_instance } },
  tfae_finish
end

lemma source_affine_locally_comp_of_is_open_immersion
  {X Y Z : Scheme.{u}} [is_affine Z] (f : X ⟶ Y) (g : Y ⟶ Z) [is_open_immersion f]
  (H : source_affine_locally @P g) : source_affine_locally @P (f ≫ g) :=
by apply ((hP.open_cover_tfae g).out 0 3).mp H

lemma source_affine_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  [is_affine Y] (𝒰 : Scheme.open_cover.{u} X) [∀ i, is_affine (𝒰.obj i)] :
  source_affine_locally @P f ↔ (∀ i, P (Scheme.Γ.map (𝒰.map i ≫ f).op)) :=
⟨λ H, let h := ((hP.affine_open_cover_tfae f).out 0 2).mp H in h 𝒰,
  λ H, let h := ((hP.affine_open_cover_tfae f).out 1 0).mp in h ⟨𝒰, infer_instance, H⟩⟩

lemma is_local_source_affine_locally :
  (source_affine_locally @P).is_local :=
source_affine_locally_is_local hP.respects_iso hP.localization_preserves
  (@ring_hom.property_is_local.of_localization_span _ hP)

lemma is_local_affine_locally :
  property_is_local_at_target (affine_locally @P) :=
hP.is_local_source_affine_locally.target_affine_locally_is_local

lemma affine_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)]
  (𝒰' : ∀ i, Scheme.open_cover.{u} ((𝒰.pullback_cover f).obj i)) [∀ i j, is_affine ((𝒰' i).obj j)] :
  affine_locally @P f ↔
    (∀ i j, P (Scheme.Γ.map ((𝒰' i).map j ≫ pullback.snd).op)) :=
(hP.is_local_source_affine_locally.affine_open_cover_iff f 𝒰).trans
    (forall_congr (λ i, hP.source_affine_open_cover_iff _ (𝒰' i)))

lemma source_open_cover_iff {X Y : Scheme.{u}} (f : X ⟶ Y)
  (𝒰 : Scheme.open_cover.{u} X) :
  affine_locally @P f ↔ ∀ i, affine_locally @P (𝒰.map i ≫ f) :=
begin
  split,
  { intros H i U,
    rw morphism_restrict_comp,
    delta morphism_restrict,
    apply hP.source_affine_locally_comp_of_is_open_immersion,
    apply H },
  { intros H U,
    haveI : is_affine _ := U.2,
    apply ((hP.open_cover_tfae (f ∣_ U.1)).out 1 0).mp,
    use 𝒰.pullback_cover (X.of_restrict _),
    intro i,
    specialize H i U,
    rw morphism_restrict_comp at H,
    delta morphism_restrict at H,
    have := source_affine_locally_respects_iso hP.respects_iso,
    rw [category.assoc, affine_cancel_left_is_iso this, ← affine_cancel_left_is_iso
      this (pullback_symmetry _ _).hom, pullback_symmetry_hom_comp_snd_assoc] at H,
    exact H }
end

lemma affine_locally_of_is_open_immersion (hP : ring_hom.property_is_local @P) {X Y : Scheme}
  (f : X ⟶ Y) [hf : is_open_immersion f] : affine_locally @P f :=
begin
  intro U,
  haveI H : is_affine _ := U.2,
  rw ← category.comp_id (f ∣_ U),
  apply hP.source_affine_locally_comp_of_is_open_immersion,
  rw hP.source_affine_open_cover_iff _ (Scheme.open_cover_of_is_iso (𝟙 _)),
  { intro i, erw [category.id_comp, op_id, Scheme.Γ.map_id],
    convert hP.holds_for_localization_away _ (1 : Scheme.Γ.obj _),
    { exact (ring_hom.algebra_map_to_algebra _).symm },
    { apply_instance },
    { refine is_localization.away_of_is_unit_of_bijective _ is_unit_one function.bijective_id } },
  { intro i, exact H }
end

lemma affine_locally_of_comp
  (H : ∀ {R S T : Type.{u}} [comm_ring R] [comm_ring S] [comm_ring T], by exactI
    ∀ (f : R →+* S) (g : S →+* T), P (g.comp f) → P g)
  {X Y Z : Scheme} {f : X ⟶ Y} {g : Y ⟶ Z} (h : affine_locally @P (f ≫ g)) :
  affine_locally @P f :=
begin
  let 𝒰 : ∀ i, ((Z.affine_cover.pullback_cover (f ≫ g)).obj i).open_cover,
  { intro i,
    refine Scheme.open_cover.bind _ (λ i, Scheme.affine_cover _),
    apply Scheme.open_cover.pushforward_iso _
    (pullback_right_pullback_fst_iso g (Z.affine_cover.map i) f).hom,
    apply Scheme.pullback.open_cover_of_right,
    exact (pullback g (Z.affine_cover.map i)).affine_cover },
  haveI h𝒰 : ∀ i j, is_affine ((𝒰 i).obj j), by { dsimp, apply_instance },
  let 𝒰' := (Z.affine_cover.pullback_cover g).bind (λ i, Scheme.affine_cover _),
  haveI h𝒰' : ∀ i, is_affine (𝒰'.obj i), by { dsimp, apply_instance },
  rw hP.affine_open_cover_iff f 𝒰' (λ i, Scheme.affine_cover _),
  rw hP.affine_open_cover_iff (f ≫ g) Z.affine_cover 𝒰 at h,
  rintros ⟨i, j⟩ k,
  dsimp at i j k,
  specialize h i ⟨j, k⟩,
  dsimp only [Scheme.open_cover.bind_map, Scheme.open_cover.pushforward_iso_obj,
    Scheme.pullback.open_cover_of_right_obj, Scheme.open_cover.pushforward_iso_map,
    Scheme.pullback.open_cover_of_right_map, Scheme.open_cover.bind_obj,
    Scheme.open_cover.pullback_cover_obj, Scheme.open_cover.pullback_cover_map] at h ⊢,
  rw [category.assoc, category.assoc, pullback_right_pullback_fst_iso_hom_snd,
    pullback.lift_snd_assoc, category.assoc, ← category.assoc, op_comp, functor.map_comp] at h,
  exact H _ _ h,
end

lemma affine_locally_stable_under_composition :
  (affine_locally @P).stable_under_composition :=
begin
  intros X Y S f g hf hg,
  let 𝒰 : ∀ i, ((S.affine_cover.pullback_cover (f ≫ g)).obj i).open_cover,
  { intro i,
    refine Scheme.open_cover.bind _ (λ i, Scheme.affine_cover _),
    apply Scheme.open_cover.pushforward_iso _
    (pullback_right_pullback_fst_iso g (S.affine_cover.map i) f).hom,
    apply Scheme.pullback.open_cover_of_right,
    exact (pullback g (S.affine_cover.map i)).affine_cover },
  rw hP.affine_open_cover_iff (f ≫ g) S.affine_cover _,
  rotate,
  { exact 𝒰 },
  { intros i j, dsimp at *, apply_instance },
  { rintros i ⟨j, k⟩,
    dsimp at i j k,
    dsimp only [Scheme.open_cover.bind_map, Scheme.open_cover.pushforward_iso_obj,
      Scheme.pullback.open_cover_of_right_obj, Scheme.open_cover.pushforward_iso_map,
      Scheme.pullback.open_cover_of_right_map, Scheme.open_cover.bind_obj],
    rw [category.assoc, category.assoc, pullback_right_pullback_fst_iso_hom_snd,
      pullback.lift_snd_assoc, category.assoc, ← category.assoc, op_comp, functor.map_comp],
    apply hP.stable_under_composition,
    { exact (hP.affine_open_cover_iff _ _ _).mp hg _ _ },
    { delta affine_locally at hf,
      rw (hP.is_local_source_affine_locally.affine_open_cover_tfae f).out 0 3 at hf,
      specialize hf ((pullback g (S.affine_cover.map i)).affine_cover.map j ≫ pullback.fst),
      rw (hP.affine_open_cover_tfae (pullback.snd : pullback f ((pullback g (S.affine_cover.map i))
        .affine_cover.map j ≫ pullback.fst) ⟶ _)).out 0 3 at hf,
      apply hf } }
end

lemma source_affine_locally_stable_under_base_change (h : ring_hom.stable_under_base_change @P) :
  (source_affine_locally @P).stable_under_base_change :=
begin
  intros X Y S hS hX f g H,
  resetI,
  rw (hP.affine_open_cover_tfae (pullback.fst : pullback f g ⟶ _)).out 0 1,
  rw (hP.affine_open_cover_tfae g).out 0 2 at H,
  use Scheme.pullback.open_cover_of_right Y.affine_cover f g,
  split,
  { intro i, dsimp, apply_instance },
  intro i,
  erw pullback.lift_fst,
  rw category.comp_id,
  exact h.Γ_pullback_fst hP.respects_iso _ _ (H Y.affine_cover i),
end

lemma affine_locally_stable_under_base_change (h : ring_hom.stable_under_base_change @P) :
  (affine_locally @P).stable_under_base_change :=
hP.is_local_source_affine_locally.stable_under_base_change
  (source_affine_locally_stable_under_base_change hP h)

lemma affine_locally_local_at_source :
  property_is_local_at_source (affine_locally @P) :=
begin
  constructor,
  { exact target_affine_locally_respects_iso (source_affine_locally_respects_iso hP.respects_iso) },
  { intros, apply affine_locally_stable_under_composition hP,
    { apply affine_locally_of_is_open_immersion hP },
    { assumption } },
  { intros, rwa source_open_cover_iff hP f 𝒰 }
end

end ring_hom.property_is_local

namespace algebraic_geometry

include P

def affine_and : affine_target_morphism_property :=
λ X Y f hY, is_affine X ∧ P (Scheme.Γ.map f.op)

variable {P}

lemma affine_and_target_affine_locally_iff (hP : ring_hom.respects_iso @P)
  {X Y : Scheme} (f : X ⟶ Y) :
  target_affine_locally (affine_and @P) f ↔
    affine f ∧ (∀ U : opens Y.carrier, is_affine_open U → P (f.1.c.app (op U))) :=
begin
  delta target_affine_locally Scheme.affine_opens,
  simp_rw [affine_iff, ← forall_and_distrib, set_coe.forall],
  apply forall₂_congr,
  intros U hU,
  apply and_congr iff.rfl,
  rw [Γ_map_morphism_restrict, hP.cancel_left_is_iso, hP.cancel_right_is_iso],
  refl
end

omit P

variable (P)

lemma target_affine_locally_affine_and_le_affine :
  target_affine_locally (affine_and @P) ≤ @affine :=
begin
  rw affine_eq_affine_property,
  apply target_affine_locally_mono,
  exact λ X Y f hY H, H.1
end

variable {P}

lemma _root_.ring_hom.property_is_local.affine_and_eq (hP : ring_hom.property_is_local @P) :
  target_affine_locally (affine_and @P) = @affine ⊓ affine_locally @P :=
begin
  rw [affine_eq_affine_property, ← target_affine_locally_and],
  congr' 1,
  ext X Y f hY,
  resetI,
  split,
  { intro H, refine ⟨H.1, _⟩,
    rw (hP.affine_open_cover_tfae f).out 0 1,
    refine ⟨Scheme.open_cover_of_is_iso (𝟙 _), λ i, H.1, λ _, _⟩,
    rw [Scheme.open_cover_of_is_iso_map, category.id_comp f],
    exact H.2 },
  { rintros ⟨h₁ : is_affine X, h₂⟩,
    rw (hP.affine_open_cover_tfae f).out 0 2 at h₂,
    have := @h₂ (Scheme.open_cover_of_is_iso (𝟙 _)) (λ _, h₁) punit.star,
    rw [Scheme.open_cover_of_is_iso_map, category.id_comp f] at this,
    refine ⟨h₁, this⟩ }
end

variable (P)

lemma is_local_affine_and
  (hP : ring_hom.respects_iso @P)
  (h₃ : ring_hom.localization_preserves @P)
  (h₄ : ring_hom.of_localization_span @P) : (affine_and @P).is_local :=
begin
  constructor,
  { apply affine_target_morphism_property.respects_iso_mk,
    { rintros X Y Z e f _ ⟨H₁, H₂⟩,
      resetI,
      refine ⟨is_affine_of_iso e.hom, _⟩,
      rw [op_comp, functor.map_comp],
      exact hP.1 (Scheme.Γ.map f.op) (Scheme.Γ.map_iso e.op).CommRing_iso_to_ring_equiv H₂ },
    { rintros X Y Z e f _ ⟨H₁, H₂⟩,
      resetI,
      refine ⟨H₁, _⟩,
      rw [op_comp, functor.map_comp],
      exact hP.2 (Scheme.Γ.map f.op) (Scheme.Γ.map_iso e.op).CommRing_iso_to_ring_equiv H₂ } },
  { rintros X Y hY f r ⟨H₁, H₂⟩,
    resetI,
    refine ⟨affine_affine_property_is_local.2 f r H₁, _⟩,
    rw hP.basic_open_iff,
    apply ring_hom.localization_preserves.away @h₃,
    all_goals { assumption } },
  { rintros X Y hY f s hs H,
    obtain ⟨H₁, H₂⟩ := forall_and_distrib.mp H,
    resetI,
    haveI := affine_affine_property_is_local.3 f s hs H₁,
    refine ⟨_, _⟩,
    swap,
    apply h₄ (Scheme.Γ.map f.op) ↑s hs,
    intro r,
    specialize H₂ r,
    rw hP.basic_open_iff_localization at H₂,
    all_goals { assumption } },
end

lemma affine_and_stable_under_composition (hP' : ring_hom.stable_under_composition @P) :
  (target_affine_locally (affine_and @P)).stable_under_composition :=
begin
  introv X h₁ h₂ U,
  obtain ⟨h₃, h₄⟩ := h₂ U,
  obtain ⟨h₅, h₆⟩ := h₁ ⟨_, h₃⟩,
  split,
  { exact h₅ },
  { rw [morphism_restrict_comp, op_comp, functor.map_comp],
    apply hP'; assumption }
end

lemma affine_and_stable_under_base_change
  (hP : ring_hom.respects_iso @P)
  (h₁ : ring_hom.localization_preserves @P)
  (h₂ : ring_hom.of_localization_span @P)
  (h₃ : _root_.ring_hom.stable_under_base_change @P) :
  (target_affine_locally (affine_and @P)).stable_under_base_change :=
begin
  apply (is_local_affine_and @P hP @h₁ @h₂).stable_under_base_change,
  rintros X Y S hS hX f g ⟨hY, H⟩,
  exactI ⟨infer_instance, h₃.Γ_pullback_fst hP _ _ H⟩
end

lemma affine_and_mono
  (P₁ P₂ : ∀ ⦃R S : Type u⦄ [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)
  (H : ∀ {R S : Type u} [comm_ring R] [comm_ring S], by exactI ∀ (f : R →+* S), P₁ f → P₂ f) :
  target_affine_locally (affine_and P₁) ≤ target_affine_locally (affine_and P₂) :=
begin
  apply target_affine_locally_mono,
  rintros X Y hY f ⟨hX, hf⟩,
  exact ⟨hX, H _ hf⟩,
end

lemma affine_and_Spec_iff {P}
  (h₁ : ring_hom.respects_iso @P) {R S : CommRing} (f : R ⟶ S) :
  affine_and @P (Scheme.Spec.map f.op) ↔ P f :=
begin
  dsimp only [affine_and],
  rw and_iff_right (show is_affine (Scheme.Spec.obj (op S)), by apply_instance),
  have := arrow.iso_w (Γ_Spec_arrow_iso f),
  dsimp only [arrow.mk_hom] at this,
  rw [this, h₁.cancel_left_is_iso, h₁.cancel_right_is_iso],
end

end algebraic_geometry


open classical

theorem dne {p : Prop} (h : ¬¬p) : p :=
  or.elim (em p)
    (assume hp : p, hp)
    (assume hnp : ¬p, absurd hnp h)


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

Traversable instance for lazy_lists.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.equiv
import Mathlib.control.traversable.instances
import Mathlib.Lean3Lib.data.lazy_list
import Mathlib.PostPort

universes u_1 u u_2 u_3

namespace Mathlib

/-!
## Definitions on lazy lists

This file contains various definitions and proofs on lazy lists.

TODO: move the `lazy_list.lean` file from core to mathlib.
-/

namespace thunk

/-- Creates a thunk with a (non-lazy) constant value. -/
def mk {α : Type u_1} (x : α) : thunk α := fun (_x : Unit) => x

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (thunk α) := sorry

end thunk

namespace lazy_list

/-- Isomorphism between strict and lazy lists. -/
def list_equiv_lazy_list (α : Type u_1) : List α ≃ lazy_list α :=
  equiv.mk of_list to_list sorry sorry

protected instance inhabited {α : Type u} : Inhabited (lazy_list α) := { default := nil }

protected instance decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (lazy_list α) := sorry

/-- Traversal of lazy lists using an applicative effect. -/
protected def traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u}
    (f : α → m β) : lazy_list α → m (lazy_list β) :=
  sorry

protected instance traversable : traversable lazy_list := traversable.mk lazy_list.traverse

protected instance is_lawful_traversable : is_lawful_traversable lazy_list :=
  equiv.is_lawful_traversable' list_equiv_lazy_list sorry sorry sorry

/-- `init xs`, if `xs` non-empty, drops the last element of the list.
Otherwise, return the empty list. -/
def init {α : Type u_1} : lazy_list α → lazy_list α := sorry

/-- Return the first object contained in the list that satisfies
predicate `p` -/
def find {α : Type u_1} (p : α → Prop) [decidable_pred p] : lazy_list α → Option α := sorry

/-- `interleave xs ys` creates a list where elements of `xs` and `ys` alternate. -/
def interleave {α : Type u_1} : lazy_list α → lazy_list α → lazy_list α := sorry

/-- `interleave_all (xs::ys::zs::xss)` creates a list where elements of `xs`, `ys`
and `zs` and the rest alternate. Every other element of the resulting list is taken from
`xs`, every fourth is taken from `ys`, every eighth is taken from `zs` and so on. -/
def interleave_all {α : Type u_1} : List (lazy_list α) → lazy_list α := sorry

/-- Monadic bind operation for `lazy_list`. -/
protected def bind {α : Type u_1} {β : Type u_2} : lazy_list α → (α → lazy_list β) → lazy_list β :=
  sorry

/-- Reverse the order of a `lazy_list`.
It is done by converting to a `list` first because reversal involves evaluating all
the list and if the list is all evaluated, `list` is a better representation for
it than a series of thunks. -/
def reverse {α : Type u_1} (xs : lazy_list α) : lazy_list α := of_list (list.reverse (to_list xs))

protected instance monad : Monad lazy_list := sorry

theorem append_nil {α : Type u_1} (xs : lazy_list α) : (append xs fun (_ : Unit) => nil) = xs :=
  sorry

theorem append_assoc {α : Type u_1} (xs : lazy_list α) (ys : lazy_list α) (zs : lazy_list α) :
    (append (append xs fun (_ : Unit) => ys) fun (_ : Unit) => zs) =
        append xs fun (_ : Unit) => append ys fun (_ : Unit) => zs :=
  sorry

theorem append_bind {α : Type u_1} {β : Type u_2} (xs : lazy_list α) (ys : thunk (lazy_list α))
    (f : α → lazy_list β) :
    lazy_list.bind (append xs ys) f =
        append (lazy_list.bind xs f) fun (_ : Unit) => lazy_list.bind (ys Unit.unit) f :=
  sorry

protected instance is_lawful_monad : is_lawful_monad lazy_list := sorry

/-- Try applying function `f` to every element of a `lazy_list` and
return the result of the first attempt that succeeds. -/
def mfirst {m : Type u_1 → Type u_2} [alternative m] {α : Type u_3} {β : Type u_1} (f : α → m β) :
    lazy_list α → m β :=
  sorry

/-- Membership in lazy lists -/
protected def mem {α : Type u_1} (x : α) : lazy_list α → Prop := sorry

protected instance has_mem {α : outParam (Type u_1)} : has_mem α (lazy_list α) :=
  has_mem.mk lazy_list.mem

protected instance mem.decidable {α : Type u_1} [DecidableEq α] (x : α) (xs : lazy_list α) :
    Decidable (x ∈ xs) :=
  sorry

@[simp] theorem mem_nil {α : Type u_1} (x : α) : x ∈ nil ↔ False := iff.rfl

@[simp] theorem mem_cons {α : Type u_1} (x : α) (y : α) (ys : thunk (lazy_list α)) :
    x ∈ cons y ys ↔ x = y ∨ x ∈ ys Unit.unit :=
  iff.rfl

theorem forall_mem_cons {α : Type u_1} {p : α → Prop} {a : α} {l : thunk (lazy_list α)} :
    (∀ (x : α), x ∈ cons a l → p x) ↔ p a ∧ ∀ (x : α), x ∈ l Unit.unit → p x :=
  sorry

/-! ### map for partial functions -/

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on
  `a : α` satisfying `p`, then `pmap f l h` is essentially the same as `map f l`
  but is defined only when all members of `l` satisfy `p`, using the proof
  to apply `f`. -/
@[simp] def pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} (f : (a : α) → p a → β)
    (l : lazy_list α) : (∀ (a : α), a ∈ l → p a) → lazy_list β :=
  sorry

/-- "Attach" the proof that the elements of `l` are in `l` to produce a new `lazy_list`
  with the same elements but in the type `{x // x ∈ l}`. -/
def attach {α : Type u_1} (l : lazy_list α) : lazy_list (Subtype fun (x : α) => x ∈ l) :=
  pmap Subtype.mk l sorry

protected instance has_repr {α : Type u_1} [has_repr α] : has_repr (lazy_list α) :=
  has_repr.mk fun (xs : lazy_list α) => repr (to_list xs)

end Mathlib


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.dlist
import tactic.core
import tactic.clear

/-!

# Recursive cases (`rcases`) tactic and related tactics

`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

The patterns are fairly liberal about the exact shape of the constructors, and will insert
additional alternation branches and tuple arguments if there are not enough arguments provided, and
reuse the tail for further matches if there are too many arguments provided to alternation and
tuple patterns.

This file also contains the `obtain` and `rintro` tactics, which use the same syntax of `rcases`
patterns but with a slightly different use case:

* `rintro` (or `rintros`) is used like `rintro x ⟨y, z⟩` and is the same as `intros` followed by
  `rcases` on the newly introduced arguments.
* `obtain` is the same as `rcases` but with a syntax styled after `have` rather than `cases`.
  `obtain ⟨hx, hy⟩ | hz := foo` is equivalent to `rcases foo with ⟨hx, hy⟩ | hz`. Unlike `rcases`,
  `obtain` also allows one to omit `:= foo`, although a type must be provided in this case,
  as in `obtain ⟨hx, hy⟩ | hz : a ∧ b ∨ c`, in which case it produces a subgoal for proving
  `a ∧ b ∨ c` in addition to the subgoals `hx : a, hy : b |- goal` and `hz : c |- goal`.

## Tags

rcases, rintro, obtain, destructuring, cases, pattern matching, match
-/

open lean lean.parser

namespace tactic

/-!
These synonyms for `list` are used to clarify the meanings of the many
usages of lists in this module.

- `listΣ` is used where a list represents a disjunction, such as the
  list of possible constructors of an inductive type.

- `listΠ` is used where a list represents a conjunction, such as the
  list of arguments of an individual constructor.

These are merely type synonyms, and so are not checked for consistency
by the compiler.

The `def`/`local notation` combination makes Lean retain these
annotations in reported types.
-/

/-- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
@[reducible] def list_Sigma := list

/-- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
@[reducible] def list_Pi := list

local notation `listΣ` := list_Sigma
local notation `listΠ` := list_Pi

/-- A metavariable representing a subgoal, together with a list of local constants to clear. -/
@[reducible] meta def uncleared_goal := list expr × expr

/--
An `rcases` pattern can be one of the following, in a nested combination:

* A name like `foo`
* The special keyword `rfl` (for pattern matching on equality using `subst`)
* A hyphen `-`, which clears the active hypothesis and any dependents.
* A type ascription like `pat : ty` (parentheses are optional)
* A tuple constructor like `⟨p1, p2, p3⟩`
* An alternation / variant pattern `p1 | p2 | p3`

Parentheses can be used for grouping; alternation is higher precedence than type ascription, so
`p1 | p2 | p3 : ty` means `(p1 | p2 | p3) : ty`.

N-ary alternations are treated as a group, so `p1 | p2 | p3` is not the same as `p1 | (p2 | p3)`,
and similarly for tuples. However, note that an n-ary alternation or tuple can match an n-ary
conjunction or disjunction, because if the number of patterns exceeds the number of constructors in
the type being destructed, the extra patterns will match on the last element, meaning that
`p1 | p2 | p3` will act like `p1 | (p2 | p3)` when matching `a1 ∨ a2 ∨ a3`. If matching against a
type with 3 constructors,  `p1 | (p2 | p3)` will act like `p1 | (p2 | p3) | _` instead.
-/
meta inductive rcases_patt : Type
| one : name → rcases_patt
| clear : rcases_patt
| typed : rcases_patt → pexpr → rcases_patt
| tuple : listΠ rcases_patt → rcases_patt
| alts : listΣ rcases_patt → rcases_patt

namespace rcases_patt
meta instance inhabited : inhabited rcases_patt :=
⟨one `_⟩

/-- Get the name from a pattern, if provided -/
meta def name : rcases_patt → option name
| (one `_) := none
| (one `rfl) := none
| (one n) := some n
| (typed p _) := p.name
| (alts [p]) := p.name
| _ := none

/-- Interpret an rcases pattern as a tuple, where `p` becomes `⟨p⟩`
if `p` is not already a tuple. -/
meta def as_tuple : rcases_patt → listΠ rcases_patt
| (tuple ps) := ps
| p := [p]

/-- Interpret an rcases pattern as an alternation, where non-alternations are treated as one
alternative. -/
meta def as_alts : rcases_patt → listΣ rcases_patt
| (alts ps) := ps
| p := [p]

/-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
meta def tuple' : listΠ rcases_patt → rcases_patt
| [p] := p
| ps := tuple ps

/-- Convert a list of patterns to an alternation pattern, but mapping `[p]` to `p` instead of
a unary alternation `|p`. -/
meta def alts' : listΣ rcases_patt → rcases_patt
| [p] := p
| ps := alts ps

/-- This function is used for producing rcases patterns based on a case tree. Suppose that we have
a list of patterns `ps` that will match correctly against the branches of the case tree for one
constructor. This function will merge tuples at the end of the list, so that `[a, b, ⟨c, d⟩]`
becomes `⟨a, b, c, d⟩` instead of `⟨a, b, ⟨c, d⟩⟩`.

We must be careful to turn `[a, ⟨⟩]` into `⟨a, ⟨⟩⟩` instead of `⟨a⟩` (which will not perform the
nested match). -/
meta def tuple₁_core : listΠ rcases_patt → listΠ rcases_patt
| [] := []
| [tuple []] := [tuple []]
| [tuple ps] := ps
| (p :: ps) := p :: tuple₁_core ps

/-- This function is used for producing rcases patterns based on a case tree. This is like
`tuple₁_core` but it produces a pattern instead of a tuple pattern list, converting `[n]` to `n`
instead of `⟨n⟩` and `[]` to `_`, and otherwise just converting `[a, b, c]` to `⟨a, b, c⟩`. -/
meta def tuple₁ : listΠ rcases_patt → rcases_patt
| [] := default _
| [one n] := one n
| ps := tuple (tuple₁_core ps)

/-- This function is used for producing rcases patterns based on a case tree. Here we are given
the list of patterns to apply to each argument of each constructor after the main case, and must
produce a list of alternatives with the same effect. This function calls `tuple₁` to make the
individual alternatives, and handles merging `[a, b, c | d]` to `a | b | c | d` instead of
`a | b | (c | d)`. -/
meta def alts₁_core : listΣ (listΠ rcases_patt) → listΣ rcases_patt
| [] := []
| [[alts ps]] := ps
| (p :: ps) := tuple₁ p :: alts₁_core ps

/-- This function is used for producing rcases patterns based on a case tree. This is like
`alts₁_core`, but it produces a cases pattern directly instead of a list of alternatives. We
specially translate the empty alternation to `⟨⟩`, and translate `|(a | b)` to `⟨a | b⟩` (because we
don't have any syntax for unary alternation). Otherwise we can use the regular merging of
alternations at the last argument so that `a | b | (c | d)` becomes `a | b | c | d`. -/
meta def alts₁ : listΣ (listΠ rcases_patt) → rcases_patt
| [[]] := tuple []
| [[alts ps]] := tuple [alts ps]
| ps := alts' (alts₁_core ps)

meta instance has_reflect : has_reflect rcases_patt
| (one n) := `(_)
| clear := `(_)
| (typed l e) :=
  (`(typed).subst (has_reflect l)).subst (reflect e)
| (tuple l) := `(λ l, tuple l).subst $
  by haveI := has_reflect; exact list.reflect l
| (alts l) := `(λ l, alts l).subst $
  by haveI := has_reflect; exact list.reflect l

/-- Formats an `rcases` pattern. If the `bracket` argument is true, then it will be
printed at high precedence, i.e. it will have parentheses around it if it is not already a tuple
or atomic name. -/
protected meta def format : ∀ bracket : bool, rcases_patt → tactic _root_.format
| _ (one n) := pure $ to_fmt n
| _ clear := pure "-"
| _ (tuple []) := pure "⟨⟩"
| _ (tuple ls) := do
  fs ← ls.mmap $ format ff,
  pure $ "⟨" ++ _root_.format.group (_root_.format.nest 1 $
    _root_.format.join $ list.intersperse ("," ++ _root_.format.line) fs) ++ "⟩"
| br (alts ls) := do
  fs ← ls.mmap $ format tt,
  let fmt := _root_.format.join $ list.intersperse (↑" |" ++ _root_.format.space) fs,
  pure $ if br then _root_.format.bracket "(" ")" fmt else fmt
| br (typed p e) := do
  fp ← format ff p,
  fe ← pp e,
  let fmt := fp ++ " : " ++ fe,
  pure $ if br then _root_.format.bracket "(" ")" fmt else fmt

meta instance has_to_tactic_format : has_to_tactic_format rcases_patt := ⟨rcases_patt.format ff⟩

end rcases_patt

/-- Takes the number of fields of a single constructor and patterns to match its fields against
(not necessarily the same number). The returned lists each contain one element per field of the
constructor. The `name` is the name which will be used in the top-level `cases` tactic, and the
`rcases_patt` is the pattern which the field will be matched against by subsequent `cases`
tactics. -/
meta def rcases.process_constructor :
  nat → listΠ rcases_patt → listΠ name × listΠ rcases_patt
| 0     ps  := ([], [])
| 1     []  := ([`_], [default _])
| 1     [p] := ([p.name.get_or_else `_], [p])

-- The interesting case: we matched the last field against multiple
-- patterns, so split off the remaining patterns into a subsequent
-- match. This handles matching `α × β × γ` against `⟨a, b, c⟩`.
| 1     ps  := ([`_], [rcases_patt.tuple ps])

| (n+1) ps  :=
  let hd := ps.head, (ns, tl) := rcases.process_constructor n ps.tail in
  (hd.name.get_or_else `_ :: ns, hd :: tl)

/-- Takes a list of constructor names, and an (alternation) list of patterns, and matches each
pattern against its constructor. It returns the list of names that will be passed to `cases`,
and the list of `(constructor name, patterns)` for each constructor, where `patterns` is the
(conjunctive) list of patterns to apply to each constructor argument. -/
meta def rcases.process_constructors (params : nat) :
  listΣ name → listΣ rcases_patt →
  tactic (dlist name × listΣ (name × listΠ rcases_patt))
| []      ps := pure (dlist.empty, [])
| (c::cs) ps := do
  n ← mk_const c >>= get_arity,
  let (h, t) := (match cs, ps.tail with
  -- We matched the last constructor against multiple patterns,
  -- so split off the remaining constructors. This handles matching
  -- `α ⊕ β ⊕ γ` against `a|b|c`.
  | [], _::_ := ([rcases_patt.alts ps], [])
  | _, _ := (ps.head.as_tuple, ps.tail)
  end : _),
  let (ns, ps) := rcases.process_constructor (n - params) h,
  (l, r) ← rcases.process_constructors cs t,
  pure (dlist.of_list ns ++ l, (c, ps) :: r)

/-- Like `zip`, but only elements satisfying a matching predicate `p` will go in the list,
and elements of the first list that fail to match the second list will be skipped. -/
private def align {α β} (p : α → β → Prop) [∀ a b, decidable (p a b)] :
  list α → list β → list (α × β)
| (a::as) (b::bs) :=
  if p a b then (a, b) :: align as bs else align as (b::bs)
| _ _ := []

/-- Given a local constant `e`, get its type. *But* if `e` does not exist, go find a hypothesis
with the same pretty name as `e` and get it instead. This is needed because we can sometimes lose
track of the unique names of hypotheses when they are revert/intro'd by `change` and `cases`. (A
better solution would be for these tactics to return a map of renamed hypotheses so that we don't
lose track of them.) -/
private meta def get_local_and_type (e : expr) : tactic (expr × expr) :=
(do t ← infer_type e, pure (t, e)) <|> (do
    e ← get_local e.local_pp_name,
    t ← infer_type e, pure (t, e))

/--
* `rcases_core p e` will match a pattern `p` against a local hypothesis `e`.
  It returns the list of subgoals that were produced.
* `rcases.continue pes` will match a (conjunctive) list of `(p, e)` pairs which refer to
  patterns and local hypotheses to match against, and applies all of them. Note that this can
  involve matching later arguments multiple times given earlier arguments, for example
  `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d⟩` match twice, once on the `a` branch and once on `b`.
-/
meta mutual def rcases_core, rcases.continue
with rcases_core : rcases_patt → expr → tactic (list uncleared_goal)
| (rcases_patt.one `rfl) e := do
  (t, e) ← get_local_and_type e,
  subst e,
  list.map (prod.mk []) <$> get_goals
-- If the pattern is any other name, we already bound the name in the
-- top-level `cases` tactic, so there is no more work to do for it.
| (rcases_patt.one _) _ := list.map (prod.mk []) <$> get_goals
| rcases_patt.clear e := do
  m ← try_core (get_local_and_type e),
  list.map (prod.mk $ m.elim [] (λ ⟨_, e⟩, [e])) <$> get_goals
| (rcases_patt.typed p ty) e := do
  (t, e) ← get_local_and_type e,
  ty ← i_to_expr_no_subgoals ``(%%ty : Sort*),
  unify t ty,
  t ← instantiate_mvars t,
  ty ← instantiate_mvars ty,
  e ← if t =ₐ ty then pure e else
    change_core ty (some e) >> get_local e.local_pp_name,
  rcases_core p e
| (rcases_patt.alts [p]) e := rcases_core p e
| pat e := do
  (t, e) ← get_local_and_type e,
  t ← whnf t,
  env ← get_env,
  let I := t.get_app_fn.const_name,
  let pat := pat.as_alts,
  (ids, r, l) ← (if I ≠ `quot
  then do
    when (¬env.is_inductive I) $
      fail format!"rcases tactic failed: {e} : {I} is not an inductive datatype",
    let params := env.inductive_num_params I,
    let c := env.constructors_of I,
    (ids, r) ← rcases.process_constructors params c pat,
    l ← cases_core e ids.to_list,
    pure (ids, r, l)
  else do
    (ids, r) ← rcases.process_constructors 2 [`quot.mk] pat,
    [(_, d)] ← induction e ids.to_list `quot.induction_on |
      fail format!"quotient induction on {e} failed. Maybe goal is not in Prop?",
    -- the result from `induction` is missing the information that the original constructor was
    -- `quot.mk` so we fix this up:
    pure (ids, r, [(`quot.mk, d)])),
  gs ← get_goals,
  -- `cases_core` may not generate a new goal for every constructor,
  -- as some constructors may be impossible for type reasons. (See its
  -- documentation.) Match up the new goals with our remaining work
  -- by constructor name.
  let ls := align (λ (a : name × _) (b : _ × name × _), a.1 = b.2.1) r (gs.zip l),
  list.join <$> ls.mmap (λ⟨⟨_, ps⟩, g, _, hs, _⟩, set_goals [g] >> rcases.continue (ps.zip hs))

with rcases.continue : listΠ (rcases_patt × expr) → tactic (list uncleared_goal)
| [] := list.map (prod.mk []) <$> get_goals
| ((pat, e) :: pes) := do
  gs ← rcases_core pat e,
  list.join <$> gs.mmap (λ ⟨cs, g⟩, do
    set_goals [g],
    ugs ← rcases.continue pes,
    pure $ ugs.map $ λ ⟨cs', gs⟩, (cs ++ cs', gs))

/-- Given a list of `uncleared_goal`s, each of which is a goal metavariable and
a list of variables to clear, actually perform the clear and set the goals with the result. -/
meta def clear_goals (ugs : list uncleared_goal) : tactic unit := do
  gs ← ugs.mmap (λ ⟨cs, g⟩, do
    set_goals [g],
    cs ← cs.mfoldr (λ c cs,
      (do (_, c) ← get_local_and_type c, pure (c :: cs)) <|> pure cs) [],
    clear' tt cs,
    [g] ← get_goals,
    pure g),
  set_goals gs

/-- `rcases h e pat` performs case distinction on `e` using `pat` to
name the arising new variables and assumptions. If `h` is `some` name,
a new assumption `h : e = pat` will relate the expression `e` with the
current pattern. See the module comment for the syntax of `pat`. -/
meta def rcases (h : option name) (p : pexpr) (pat : rcases_patt) : tactic unit := do
  let p := match pat with
  | rcases_patt.typed _ ty := ``(%%p : %%ty)
  | _ := p
  end,
  e ← match h with
    | some h := do
      x ← get_unused_name $ pat.name.get_or_else `this,
      interactive.generalize h () (p, x),
      get_local x
    | none := i_to_expr p
    end,
  if e.is_local_constant then
    focus1 (rcases_core pat e >>= clear_goals)
  else do
    x ← pat.name.elim mk_fresh_name pure,
    n ← revert_kdependencies e semireducible,
    tactic.generalize e x <|> (do
      t ← infer_type e,
      tactic.assertv x t e,
      get_local x >>= tactic.revert,
      pure ()),
    h ← tactic.intro1,
    focus1 (rcases_core pat h >>= clear_goals)

/-- `rcases_many es pats` performs case distinction on the `es` using `pat` to
name the arising new variables and assumptions.
See the module comment for the syntax of `pat`. -/
meta def rcases_many (ps : listΠ pexpr) (pat : rcases_patt) : tactic unit := do
  let (_, pats) := rcases.process_constructor ps.length pat.as_tuple,
  pes ← (ps.zip pats).mmap (λ ⟨p, pat⟩, do
    let p := match pat with
    | rcases_patt.typed _ ty := ``(%%p : %%ty)
    | _ := p
    end,
    e ← i_to_expr p,
    if e.is_local_constant then
      pure (pat, e)
    else do
      x ← pat.name.elim mk_fresh_name pure,
      n ← revert_kdependencies e semireducible,
      tactic.generalize e x <|> (do
        t ← infer_type e,
        tactic.assertv x t e,
        get_local x >>= tactic.revert,
        pure ()),
      prod.mk pat <$> tactic.intro1),
  focus1 (rcases.continue pes >>= clear_goals)

/-- `rintro pat₁ pat₂ ... patₙ` introduces `n` arguments, then pattern matches on the `patᵢ` using
the same syntax as `rcases`. -/
meta def rintro (ids : listΠ rcases_patt) : tactic unit :=
do l ← ids.mmap (λ id, do
    e ← intro $ id.name.get_or_else `_,
    pure (id, e)),
  focus1 (rcases.continue l >>= clear_goals)

/-- Like `zip_with`, but if the lists don't match in length, the excess elements will be put at the
end of the result. -/
def merge_list {α} (m : α → α → α) : list α → list α → list α
| [] l₂ := l₂
| l₁ [] := l₁
| (a :: l₁) (b :: l₂) := m a b :: merge_list l₁ l₂

/-- Merge two `rcases` patterns. This is used to underapproximate a case tree by an `rcases`
pattern. The two patterns come from cases in two branches, that due to the syntax of `rcases`
patterns are forced to overlap. The rule here is that we take only the case splits that are in
common between both branches. For example if one branch does `⟨a, b⟩` and the other does `c`,
then we return `c` because we don't know that a case on `c` would be safe to do. -/
meta def rcases_patt.merge : rcases_patt → rcases_patt → rcases_patt
| (rcases_patt.alts p₁) p₂ := rcases_patt.alts (merge_list rcases_patt.merge p₁ p₂.as_alts)
| p₁ (rcases_patt.alts p₂) := rcases_patt.alts (merge_list rcases_patt.merge p₁.as_alts p₂)
| (rcases_patt.tuple p₁) p₂ := rcases_patt.tuple (merge_list rcases_patt.merge p₁ p₂.as_tuple)
| p₁ (rcases_patt.tuple p₂) := rcases_patt.tuple (merge_list rcases_patt.merge p₁.as_tuple p₂)
| (rcases_patt.typed p₁ e) p₂ := rcases_patt.typed (p₁.merge p₂) e
| p₁ (rcases_patt.typed p₂ e) := rcases_patt.typed (p₁.merge p₂) e
| (rcases_patt.one `rfl) (rcases_patt.one `rfl) := rcases_patt.one `rfl
| (rcases_patt.one `_) p := p
| p (rcases_patt.one `_) := p
| rcases_patt.clear p := p
| p rcases_patt.clear := p
| (rcases_patt.one n) _ := rcases_patt.one n

/--
* `rcases_hint_core depth e` does the same as `rcases p e`, except the pattern `p` is an output
  instead of an input, controlled only by the case depth argument `depth`. We use `cases` to depth
  `depth` and then reconstruct an `rcases` pattern `p` that would, if passed to `rcases`, perform
  the same thing as the case tree we just constructed (or at least, the nearest expressible
  approximation to this.)
* `rcases_hint.process_constructors depth cs l` takes a list of constructor names `cs` and a
  matching list `l` of elements `(g, c', hs, _)` where  `c'` is a constructor name (used for
  alignment with `cs`), `g` is the subgoal, and `hs` is the list of local hypotheses created by
  `cases` in that subgoal. It matches on all of them, and then produces a `ΣΠ`-list of `rcases`
  patterns describing the result, and the list of generated subgoals.
* `rcases_hint.continue depth es` does the same as `rcases.continue (ps.zip es)`, except the
  patterns `ps` are an output instead of an input, created by matching on everything to depth
  `depth` and recording the successful cases. It returns `ps`, and the list of generated subgoals.
-/
meta mutual def rcases_hint_core, rcases_hint.process_constructors, rcases_hint.continue
with rcases_hint_core : ℕ → expr → tactic (rcases_patt × list expr)
| depth e := do
  (t, e) ← get_local_and_type e,
  t ← whnf t,
  env ← get_env,
  let I := t.get_app_fn.const_name,
  (do guard (I = ``eq),
    subst e,
    prod.mk (rcases_patt.one `rfl) <$> get_goals) <|>
  (do
    let c := env.constructors_of I,
    some l ← try_core (guard (depth ≠ 0) >> cases_core e) |
      let n := match e.local_pp_name with name.anonymous := `_ | n := n end in
      prod.mk (rcases_patt.one n) <$> get_goals,
    gs ← get_goals,
    if gs.empty then
      pure (rcases_patt.tuple [], [])
    else do
      (ps, gs') ← rcases_hint.process_constructors (depth - 1) c (gs.zip l),
      pure (rcases_patt.alts₁ ps, gs'))

with rcases_hint.process_constructors : ℕ → listΣ name →
  list (expr × name × listΠ expr × list (name × expr)) →
  tactic (listΣ (listΠ rcases_patt) × list expr)
| depth [] _  := pure ([], [])
| depth cs [] := pure (cs.map (λ _, []), [])
| depth (c::cs) ls@((g, c', hs, _) :: l) :=
  if c ≠ c' then do
    (ps, gs) ← rcases_hint.process_constructors depth cs ls,
    pure ([] :: ps, gs)
  else do
    (p, gs) ← set_goals [g] >> rcases_hint.continue depth hs,
    (ps, gs') ← rcases_hint.process_constructors depth cs l,
    pure (p :: ps, gs ++ gs')

with rcases_hint.continue : ℕ → listΠ expr → tactic (listΠ rcases_patt × list expr)
| depth [] := prod.mk [] <$> get_goals
| depth (e :: es) := do
  (p, gs) ← rcases_hint_core depth e,
  (ps, gs') ← gs.mfoldl (λ (r : listΠ rcases_patt × list expr) g,
    do (ps, gs') ← set_goals [g] >> rcases_hint.continue depth es,
      pure (merge_list rcases_patt.merge r.1 ps, r.2 ++ gs')) ([], []),
  pure (p :: ps, gs')

/--
* `rcases? e` is like `rcases e with ...`, except it generates `...` by matching on everything it
can, and it outputs an `rcases` invocation that should have the same effect.
* `rcases? e : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
meta def rcases_hint (p : pexpr) (depth : nat) : tactic rcases_patt :=
do e ← i_to_expr p,
  if e.is_local_constant then
    focus1 $ do (p, gs) ← rcases_hint_core depth e, set_goals gs, pure p
  else do
    x ← mk_fresh_name,
    n ← revert_kdependencies e semireducible,
    tactic.generalize e x <|> (do
      t ← infer_type e,
      tactic.assertv x t e,
      get_local x >>= tactic.revert,
      pure ()),
    h ← tactic.intro1,
    focus1 $ do (p, gs) ← rcases_hint_core depth h, set_goals gs, pure p

/--
* `rcases? ⟨e1, e2, e3⟩` is like `rcases ⟨e1, e2, e3⟩ with ...`, except it
  generates `...` by matching on everything it can, and it outputs an `rcases`
  invocation that should have the same effect.
* `rcases? ⟨e1, e2, e3⟩ : n` can be used to control the depth of case splits
  (especially important for recursive types like `nat`, which can be cased as many
  times as you like). -/
meta def rcases_hint_many (ps : list pexpr) (depth : nat) : tactic (listΠ rcases_patt) :=
do es ← ps.mmap (λ p, do
    e ← i_to_expr p,
    if e.is_local_constant then pure e
    else do
      x ← mk_fresh_name,
      n ← revert_kdependencies e semireducible,
      tactic.generalize e x <|> (do
        t ← infer_type e,
        tactic.assertv x t e,
        get_local x >>= tactic.revert,
        pure ()),
      tactic.intro1),
  focus1 $ do
    (ps, gs) ← rcases_hint.continue depth es,
    set_goals gs,
    pure ps

/--
* `rintro?` is like `rintro ...`, except it generates `...` by introducing and matching on
everything it can, and it outputs an `rintro` invocation that should have the same effect.
* `rintro? : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
meta def rintro_hint (depth : nat) : tactic (listΠ rcases_patt) :=
do l ← intros,
  focus1 $ do
    (p, gs) ← rcases_hint.continue depth l,
    set_goals gs,
    pure p

setup_tactic_parser

/--
* `rcases_patt_parse tt` will parse a high precedence `rcases` pattern, `patt_hi`.
  This means only tuples and identifiers are allowed; alternations and type ascriptions
  require `(...)` instead, which switches to `patt`.
* `rcases_patt_parse ff` will parse a low precedence `rcases` pattern, `patt`. This consists of a
  `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
  expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
  example in `rcases e with x : ty <|> skip`.
* `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
  patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
  `(a | b) : ty` where `a | b` is the `patt_med` part.
* `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

```lean
patt ::= patt_med (":" expr)?
patt_med ::= (patt_hi "|")* patt_hi
patt_hi ::= id | "rfl" | "_" | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
```
-/
meta mutual def rcases_patt_parse, rcases_patt_parse_list, rcases_patt_parse_list_rest
with rcases_patt_parse : bool → parser rcases_patt
| tt := with_desc "patt_hi" $
  (brackets "(" ")" (rcases_patt_parse ff)) <|>
  (rcases_patt.tuple <$> brackets "⟨" "⟩" (sep_by (tk ",") (rcases_patt_parse ff))) <|>
  (tk "-" $> rcases_patt.clear) <|>
  (rcases_patt.one <$> ident_)
| ff := with_desc "patt" $ do
  pat ← rcases_patt.alts' <$> rcases_patt_parse_list,
  (tk ":" *> pat.typed <$> texpr) <|> pure pat

with rcases_patt_parse_list : parser (listΣ rcases_patt)
| x := (with_desc "patt_med" $ rcases_patt_parse tt >>= rcases_patt_parse_list_rest) x

with rcases_patt_parse_list_rest : rcases_patt → parser (listΣ rcases_patt)
| pat :=
  (tk "|" *> list.cons pat <$> rcases_patt_parse_list) <|>
  -- hack to support `-|-` patterns, because `|-` is a token
  (tk "|-" *> list.cons pat <$> rcases_patt_parse_list_rest rcases_patt.clear) <|>
  pure [pat]

/-- Parse the optional depth argument `(: n)?` of `rcases?` and `rintro?`, with default depth 5. -/
meta def rcases_parse_depth : parser nat :=
do o ← (tk ":" *> small_nat)?, pure $ o.get_or_else 5

/-- The arguments to `rcases`, which in fact dispatch to several other tactics.
* `rcases? expr (: n)?` or `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint`
* `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint_many`
* `rcases (h :)? expr (with patt)?` calls `rcases`
* `rcases ⟨expr, ...⟩ (with patt)?` calls `rcases_many`
-/
@[derive has_reflect]
meta inductive rcases_args
| hint (tgt : pexpr ⊕ list pexpr) (depth : nat)
| rcases (name : option name) (tgt : pexpr) (pat : rcases_patt)
| rcases_many (tgt : listΠ pexpr) (pat : rcases_patt)

/-- Syntax for a `rcases` pattern:
* `rcases? expr (: n)?`
* `rcases (h :)? expr (with patt_list (: expr)?)?`. -/
meta def rcases_parse : parser rcases_args :=
with_desc "('?' expr (: n)?) | ((h :)? expr (with patt)?)" $ do
  hint ← (tk "?")?,
  p ← (sum.inr <$> brackets "⟨" "⟩" (sep_by (tk ",") (parser.pexpr 0))) <|>
      (sum.inl <$> texpr),
  match hint with
  | none := do
    p ← (do
      sum.inl (expr.local_const h _ _ _) ← pure p,
      tk ":" *> (@sum.inl _ (pexpr ⊕ list pexpr) ∘ prod.mk h) <$> texpr) <|>
      pure (sum.inr p),
    ids ← (tk "with" *> rcases_patt_parse ff)?,
    let ids := ids.get_or_else (rcases_patt.tuple []),
    pure $ match p with
    | sum.inl (name, tgt) := rcases_args.rcases (some name) tgt ids
    | sum.inr (sum.inl tgt) := rcases_args.rcases none tgt ids
    | sum.inr (sum.inr tgts) := rcases_args.rcases_many tgts ids
    end
  | some _ := do
    depth ← rcases_parse_depth,
    pure $ rcases_args.hint p depth
  end

/--
`rintro_patt_parse_hi` and `rintro_patt_parse` are like `rcases_patt_parse`, but is used for
parsing top level `rintro` patterns, which allow sequences like `(x y : t)` in addition to simple
`rcases` patterns.

* `rintro_patt_parse_hi` will parse a high precedence `rcases` pattern, `rintro_patt_hi` below.
  This means only tuples and identifiers are allowed; alternations and type ascriptions
  require `(...)` instead, which switches to `patt`.
* `rintro_patt_parse tt` will parse a low precedence `rcases` pattern, `rintro_patt` below.
  This consists of either a sequence of patterns `p1 p2 p3` or an alternation list `p1 | p2 | p3`
  treated as a single pattern, optionally followed by a `: ty` type ascription, which applies to
  every pattern in the list.
* `rintro_patt_parse ff` parses `rintro_patt_low`, which is the same as `rintro_patt_parse tt` but
  it does not permit an unparenthesized alternation list, it must have the form `p1 p2 p3 (: ty)?`.

```lean
rintro_patt ::= (rintro_patt_hi+ | patt_med) (":" expr)?
rintro_patt_low ::= rintro_patt_hi* (":" expr)?
rintro_patt_hi ::= patt_hi | "(" rintro_patt ")"
```
-/
meta mutual def rintro_patt_parse_hi, rintro_patt_parse
with rintro_patt_parse_hi : parser (listΠ rcases_patt)
| x := (with_desc "rintro_patt_hi" $
  brackets "(" ")" (rintro_patt_parse tt) <|>
  (do p ← rcases_patt_parse tt, pure [p])) x
with rintro_patt_parse : bool → parser (listΠ rcases_patt)
| med := with_desc "rintro_patt" $ do
  ll ← rintro_patt_parse_hi*,
  pats ← match med, ll.join with
  | tt, [] := failure
  | tt, [pat] := do l ← rcases_patt_parse_list_rest pat, pure [rcases_patt.alts' l]
  | _, pats := pure pats
  end,
  (do tk ":", e ← texpr, pure (pats.map (λ p, rcases_patt.typed p e))) <|>
  pure pats

/-- Syntax for a `rintro` pattern: `('?' (: n)?) | rintro_patt`. -/
meta def rintro_parse : parser (listΠ rcases_patt ⊕ nat) :=
with_desc "('?' (: n)?) | patt*" $
(tk "?" >> sum.inr <$> rcases_parse_depth) <|>
sum.inl <$> rintro_patt_parse ff

namespace interactive
open interactive interactive.types expr

/--
`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

A pattern like `⟨a, b, c⟩ | ⟨d, e⟩` will do a split over the inductive datatype,
naming the first three parameters of the first constructor as `a,b,c` and the
first two of the second constructor `d,e`. If the list is not as long as the
number of arguments to the constructor or the number of constructors, the
remaining variables will be automatically named. If there are nested brackets
such as `⟨⟨a⟩, b | c⟩ | d` then these will cause more case splits as necessary.
If there are too many arguments, such as `⟨a, b, c⟩` for splitting on
`∃ x, ∃ y, p x`, then it will be treated as `⟨a, ⟨b, c⟩⟩`, splitting the last
parameter as necessary.

`rcases` also has special support for quotient types: quotient induction into Prop works like
matching on the constructor `quot.mk`.

`rcases h : e with PAT` will do the same as `rcases e with PAT` with the exception that an
assumption `h : e = PAT` will be added to the context.

`rcases? e` will perform case splits on `e` in the same way as `rcases e`,
but rather than accepting a pattern, it does a maximal cases and prints the
pattern that would produce this case splitting. The default maximum depth is 5,
but this can be modified with `rcases? e : n`.
-/
meta def rcases : parse rcases_parse → tactic unit
| (rcases_args.rcases h p ids) := tactic.rcases h p ids
| (rcases_args.rcases_many ps ids) := tactic.rcases_many ps ids
| (rcases_args.hint p depth) := do
  (pe, patt) ← match p with
  | sum.inl p := prod.mk <$> pp p <*> rcases_hint p depth
  | sum.inr ps := do
    patts ← rcases_hint_many ps depth,
    pes ← ps.mmap pp,
    pure (format.bracket "⟨" "⟩" (format.comma_separated pes), rcases_patt.tuple patts)
  end,
  ppat ← pp patt,
  trace $ ↑"Try this: rcases " ++ pe ++ " with " ++ ppat

add_tactic_doc
{ name       := "rcases",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.rcases],
  tags       := ["induction"] }

/--
The `rintro` tactic is a combination of the `intros` tactic with `rcases` to
allow for destructuring patterns while introducing variables. See `rcases` for
a description of supported patterns. For example, `rintro (a | ⟨b, c⟩) ⟨d, e⟩`
will introduce two variables, and then do case splits on both of them producing
two subgoals, one with variables `a d e` and the other with `b c d e`.

`rintro`, unlike `rcases`, also supports the form `(x y : ty)` for introducing
and type-ascripting multiple variables at once, similar to binders.

`rintro?` will introduce and case split on variables in the same way as
`rintro`, but will also print the `rintro` invocation that would have the same
result. Like `rcases?`, `rintro? : n` allows for modifying the
depth of splitting; the default is 5.

`rintros` is an alias for `rintro`.
-/
meta def rintro : parse rintro_parse → tactic unit
| (sum.inl []) := intros []
| (sum.inl l)  := tactic.rintro l
| (sum.inr depth) := do
  ps ← tactic.rintro_hint depth,
  fs ← ps.mmap (λ p, do
    f ← pp $ p.format tt,
    pure $ format.space ++ format.group f),
  trace $ ↑"Try this: rintro" ++ format.join fs

/-- Alias for `rintro`. -/
meta def rintros := rintro

add_tactic_doc
{ name       := "rintro",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.rintro, `tactic.interactive.rintros],
  tags       := ["induction"],
  inherit_description_from := `tactic.interactive.rintro }

setup_tactic_parser

/-- Parses `patt? (: expr)? (:= expr)?`, the arguments for `obtain`.
 (This is almost the same as `rcases_patt_parse ff`,
but it allows the pattern part to be empty.) -/
meta def obtain_parse :
  parser ((option rcases_patt × option pexpr) × option (pexpr ⊕ list pexpr)) :=
with_desc "patt? (: expr)? (:= expr)?" $ do
  (pat, tp) ←
    (do pat ← rcases_patt_parse ff,
      pure $ match pat with
      | rcases_patt.typed pat tp := (some pat, some tp)
      | _ := (some pat, none)
      end) <|>
    prod.mk none <$> (tk ":" >> texpr)?,
  prod.mk (pat, tp) <$> (do
    tk ":=",
    (guard tp.is_none >>
      sum.inr <$> brackets "⟨" "⟩" (sep_by (tk ",") (parser.pexpr 0))) <|>
    (sum.inl <$> texpr))?

/--
The `obtain` tactic is a combination of `have` and `rcases`. See `rcases` for
a description of supported patterns.

```lean
obtain ⟨patt⟩ : type,
{ ... }
```
is equivalent to
```lean
have h : type,
{ ... },
rcases h with ⟨patt⟩
```

The syntax `obtain ⟨patt⟩ : type := proof` is also supported.

If `⟨patt⟩` is omitted, `rcases` will try to infer the pattern.

If `type` is omitted, `:= proof` is required.
-/
meta def obtain : parse obtain_parse → tactic unit
| ((pat, _), some (sum.inr val)) :=
  tactic.rcases_many val (pat.get_or_else (default _))
| ((pat, none), some (sum.inl val)) :=
  tactic.rcases none val (pat.get_or_else (default _))
| ((pat, some tp), some (sum.inl val)) :=
  tactic.rcases none val $ (pat.get_or_else (default _)).typed tp
| ((pat, some tp), none) := do
  nm ← mk_fresh_name,
  e ← to_expr tp >>= assert nm,
  (g :: gs) ← get_goals,
  set_goals gs,
  tactic.rcases none ``(%%e) (pat.get_or_else (rcases_patt.one `this)),
  gs ← get_goals,
  set_goals (g::gs)
| ((pat, none), none) :=
  fail $ "`obtain` requires either an expected type or a value.\n" ++
         "usage: `obtain ⟨patt⟩? : type (:= val)?` or `obtain ⟨patt⟩? (: type)? := val`"

add_tactic_doc
{ name       := "obtain",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.obtain],
  tags       := ["induction"] }

end interactive
end tactic


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

! This file was ported from Lean 3 source module data.dlist.basic
! leanprover-community/mathlib commit d6aae1bcbd04b8de2022b9b83a5b5b10e10c777d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Std.Data.DList
import Mathlib.Mathport.Rename
import Mathlib.Tactic.Cases

/-!
# Difference list

This file provides a few results about `DList`, which is defined in `Std`.

A difference list is a function that, given a list, returns the original content of the
difference list prepended to the given list. It is useful to represent elements of a given type
as `a₁ + ... + aₙ` where `+ : α → α → α` is any operation, without actually computing.

This structure supports `O(1)` `append` and `concat` operations on lists, making it
useful for append-heavy uses such as logging and pretty printing.
-/

namespace Std

/-- Concatenates a list of difference lists to form a single difference list. Similar to
`List.join`. -/
def DList.join {α : Type _} : List (DList α) → DList α
  | [] => DList.empty
  | x :: xs => x ++ DList.join xs
#align dlist.join Std.DList.join

/-- Convert a lazily-evaluated `List` to a `DList` -/
-- Ported from Lean 3 core
def DList.lazy_ofList (l : Thunk (List α)) : DList α :=
⟨fun xs => l.get ++ xs, fun t => by simp⟩
#align dlist.lazy_of_list Std.DList.lazy_ofList

@[simp]
theorem DList_singleton {α : Type _} {a : α} : DList.singleton a = DList.lazy_ofList [a] :=
  rfl
#align dlist_singleton Std.DList_singleton

@[simp]
theorem DList_lazy {α : Type _} {l : List α} : DList.lazy_ofList l = Std.DList.ofList l :=
  rfl
#align dlist_lazy Std.DList_lazy

-- Porting note: port from lean3
theorem DList.toList_ofList (l : List α) : DList.toList (DList.ofList l) = l := by
  cases l; rfl; simp only [DList.toList, DList.ofList, List.cons_append, List.append_nil]
#align dlist.to_list_of_list Std.DList.toList_ofList

-- Porting note: port from lean3

end Std


/-
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.limits
import category_theory.flat_functors
import category_theory.limits.preserves.filtered
import category_theory.sites.left_exact

/-!
# Cover-preserving functors between sites.

We define cover-preserving functors between sites as functors that push covering sieves to
covering sieves. A cover-preserving and compatible-preserving functor `G : C ⥤ D` then pulls
sheaves on `D` back to sheaves on `C` via `G.op ⋙ -`.

## Main definitions

* `category_theory.cover_preserving`: a functor between sites is cover-preserving if it
pushes covering sieves to covering sieves
* `category_theory.compatible_preserving`: a functor between sites is compatible-preserving
if it pushes compatible families of elements to compatible families.
* `category_theory.pullback_sheaf`: the pullback of a sheaf along a cover-preserving and
compatible-preserving functor.
* `category_theory.sites.pullback`: the induced functor `Sheaf K A ⥤ Sheaf J A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.
* `category_theory.sites.pushforward`: the induced functor `Sheaf J A ⥤ Sheaf K A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.
* `category_theory.sites.pushforward`: the induced functor `Sheaf J A ⥤ Sheaf K A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.

## Main results

- `category_theory.sites.whiskering_left_is_sheaf_of_cover_preserving`: If `G : C ⥤ D` is
cover-preserving and compatible-preserving, then `G ⋙ -` (`uᵖ`) as a functor
`(Dᵒᵖ ⥤ A) ⥤ (Cᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* https://stacks.math.columbia.edu/tag/00WW

-/

universes w v₁ v₂ v₃ u₁ u₂ u₃
noncomputable theory

open category_theory
open opposite
open category_theory.presieve.family_of_elements
open category_theory.presieve
open category_theory.limits

namespace category_theory
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {A : Type u₃} [category.{v₃} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology A}

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is *cover-preserving*
if for all covering sieves `R` in `C`, `R.pushforward_functor G` is a covering sieve in `D`.
-/
@[nolint has_inhabited_instance]
structure cover_preserving (G : C ⥤ D) : Prop :=
(cover_preserve : ∀ {U : C} {S : sieve U} (hS : S ∈ J U), S.functor_pushforward G ∈ K (G.obj U))

/-- The identity functor on a site is cover-preserving. -/
lemma id_cover_preserving : cover_preserving J J (𝟭 _) := ⟨λ U S hS, by simpa using hS⟩

variables (J) (K)

/-- The composition of two cover-preserving functors is cover-preserving. -/
lemma cover_preserving.comp {F} (hF : cover_preserving J K F) {G} (hG : cover_preserving K L G) :
  cover_preserving J L (F ⋙ G) := ⟨λ U S hS,
begin
  rw sieve.functor_pushforward_comp,
  exact hG.cover_preserve (hF.cover_preserve hS)
end⟩

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is called compatible preserving if for each
compatible family of elements at `C` and valued in `G.op ⋙ ℱ`, and each commuting diagram
`f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂`, `x g₁` and `x g₂` coincide when restricted via `fᵢ`.
This is actually stronger than merely preserving compatible families because of the definition of
`functor_pushforward` used.
-/
@[nolint has_inhabited_instance]
structure compatible_preserving (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(compatible :
  ∀ (ℱ : SheafOfTypes.{w} K) {Z} {T : presieve Z}
    {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)
    {Y₁ Y₂} {X} (f₁ : X ⟶ G.obj Y₁) (f₂ : X ⟶ G.obj Y₂) {g₁ : Y₁ ⟶ Z} {g₂ : Y₂ ⟶ Z}
    (hg₁ : T g₁) (hg₂ : T g₂) (eq : f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂),
      ℱ.val.map f₁.op (x g₁ hg₁) = ℱ.val.map f₂.op (x g₂ hg₂))

variables {J K} {G : C ⥤ D} (hG : compatible_preserving.{w} K G) (ℱ : SheafOfTypes.{w} K) {Z : C}
variables {T : presieve Z} {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)

include h hG

/-- `compatible_preserving` functors indeed preserve compatible families. -/
lemma presieve.family_of_elements.compatible.functor_pushforward :
  (x.functor_pushforward G).compatible :=
begin
  rintros Z₁ Z₂ W g₁ g₂ f₁' f₂' H₁ H₂ eq,
  unfold family_of_elements.functor_pushforward,
  rcases get_functor_pushforward_structure H₁ with ⟨X₁, f₁, h₁, hf₁, rfl⟩,
  rcases get_functor_pushforward_structure H₂ with ⟨X₂, f₂, h₂, hf₂, rfl⟩,
  suffices : ℱ.val.map (g₁ ≫ h₁).op (x f₁ hf₁) = ℱ.val.map (g₂ ≫ h₂).op (x f₂ hf₂),
    simpa using this,
  apply hG.compatible ℱ h _ _ hf₁ hf₂,
  simpa using eq
end

@[simp] lemma compatible_preserving.apply_map {Y : C} {f : Y ⟶ Z} (hf : T f) :
  x.functor_pushforward G (G.map f) (image_mem_functor_pushforward G T hf) = x f hf :=
begin
  unfold family_of_elements.functor_pushforward,
  rcases e₁ : get_functor_pushforward_structure (image_mem_functor_pushforward G T hf) with
    ⟨X, g, f', hg, eq⟩,
  simpa using hG.compatible ℱ h f' (𝟙 _) hg hf (by simp[eq])
end

omit h hG

open limits.walking_cospan

lemma compatible_preserving_of_flat {C : Type u₁} [category.{v₁} C] {D : Type u₁} [category.{v₁} D]
  (K : grothendieck_topology D) (G : C ⥤ D) [representably_flat G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ e,

  /- First, `f₁` and `f₂` form a cone over `cospan g₁ g₂ ⋙ u`. -/
  let c : cone (cospan g₁ g₂ ⋙ G) :=
    (cones.postcompose (diagram_iso_cospan (cospan g₁ g₂ ⋙ G)).inv).obj
      (pullback_cone.mk f₁ f₂ e),

  /-
  This can then be viewed as a cospan of structured arrows, and we may obtain an arbitrary cone
  over it since `structured_arrow W u` is cofiltered.
  Then, it suffices to prove that it is compatible when restricted onto `u(c'.X.right)`.
  -/
  let c' := is_cofiltered.cone (structured_arrow_cone.to_diagram c ⋙ structured_arrow.pre _ _ _),
  have eq₁ : f₁ = (c'.X.hom ≫ G.map (c'.π.app left).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app left).w, dsimp, simp },
  have eq₂ : f₂ = (c'.X.hom ≫ G.map (c'.π.app right).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app right).w, dsimp, simp },
  conv_lhs { rw eq₁ },
  conv_rhs { rw eq₂ },
  simp only [op_comp, functor.map_comp, types_comp_apply, eq_to_hom_op, eq_to_hom_map],
  congr' 1,

  /-
  Since everything now falls in the image of `u`,
  the result follows from the compatibility of `x` in the image of `u`.
  -/
  injection c'.π.naturality walking_cospan.hom.inl with _ e₁,
  injection c'.π.naturality walking_cospan.hom.inr with _ e₂,
  exact hx (c'.π.app left).right (c'.π.app right).right hg₁ hg₂ (e₁.symm.trans e₂)
end

/--
If `G` is cover-preserving and compatible-preserving,
then `G.op ⋙ _` pulls sheaves back to sheaves.

This result is basically https://stacks.math.columbia.edu/tag/00WW.
-/
theorem pullback_is_sheaf_of_cover_preserving {G : C ⥤ D} (hG₁ : compatible_preserving.{v₃} K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) :
  presheaf.is_sheaf J (G.op ⋙ ℱ.val) :=
begin
  intros X U S hS x hx,
  change family_of_elements (G.op ⋙ ℱ.val ⋙ coyoneda.obj (op X)) _ at x,
  let H := ℱ.2 X _ (hG₂.cover_preserve hS),
  let hx' := hx.functor_pushforward hG₁ (sheaf_over ℱ X),
  split, swap,
  { apply H.amalgamate (x.functor_pushforward G),
    exact hx' },
  split,
  { intros V f hf,
    convert H.is_amalgamation hx' (G.map f) (image_mem_functor_pushforward G S hf),
    rw hG₁.apply_map (sheaf_over ℱ X) hx },
  { intros y hy,
    refine H.is_separated_for _ y _ _
      (H.is_amalgamation (hx.functor_pushforward hG₁ (sheaf_over ℱ X))),
    rintros V f ⟨Z, f', g', h, rfl⟩,
    erw family_of_elements.comp_of_compatible (S.functor_pushforward G)
      hx' (image_mem_functor_pushforward G S h) g',
    dsimp,
    simp [hG₁.apply_map (sheaf_over ℱ X) hx h, ←hy f' h] }
end

/-- The pullback of a sheaf along a cover-preserving and compatible-preserving functor. -/
def pullback_sheaf {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) : Sheaf J A :=
⟨G.op ⋙ ℱ.val, pullback_is_sheaf_of_cover_preserving hG₁ hG₂ ℱ⟩

variable (A)

/--
The induced functor from `Sheaf K A ⥤ Sheaf J A` given by `G.op ⋙ _`
if `G` is cover-preserving and compatible-preserving.
-/
@[simps] def sites.pullback {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : Sheaf K A ⥤ Sheaf J A :=
{ obj := λ ℱ, pullback_sheaf hG₁ hG₂ ℱ,
  map := λ _ _ f, ⟨(((whiskering_left _ _ _).obj G.op)).map f.val⟩,
  map_id' := λ ℱ, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_id },
  map_comp' := λ _ _ _ f g, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_comp } }

end category_theory

namespace category_theory

variables {C : Type v₁} [small_category C] {D : Type v₁} [small_category D]
variables (A : Type u₂) [category.{v₁} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)

instance [has_limits A] : creates_limits (Sheaf_to_presheaf J A) :=
category_theory.Sheaf.category_theory.Sheaf_to_presheaf.category_theory.creates_limits.{u₂ v₁ v₁}

-- The assumptions so that we have sheafification
variables [concrete_category.{v₁} A] [preserves_limits (forget A)] [has_colimits A] [has_limits A]
variables [preserves_filtered_colimits (forget A)] [reflects_isomorphisms (forget A)]

local attribute [instance] reflects_limits_of_reflects_isomorphisms

instance {X : C} : is_cofiltered (J.cover X) := infer_instance

/-- The pushforward functor `Sheaf J A ⥤ Sheaf K A` associated to a functor `G : C ⥤ D` in the
same direction as `G`. -/
@[simps] def sites.pushforward (G : C ⥤ D) : Sheaf J A ⥤ Sheaf K A :=
Sheaf_to_presheaf J A ⋙ Lan G.op ⋙ presheaf_to_Sheaf K A

instance (G : C ⥤ D) [representably_flat G] :
  preserves_finite_limits (sites.pushforward A J K G) :=
begin
  apply_with comp_preserves_finite_limits { instances := ff },
  { apply_instance },
  apply_with comp_preserves_finite_limits { instances := ff },
  { apply category_theory.Lan_preserves_finite_limits_of_flat },
  { apply category_theory.presheaf_to_Sheaf.limits.preserves_finite_limits.{u₂ v₁ v₁},
    apply_instance }
end

/-- The pushforward functor is left adjoint to the pullback functor. -/
def sites.pullback_pushforward_adjunction {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : sites.pushforward A J K G ⊣ sites.pullback A hG₁ hG₂ :=
((Lan.adjunction A G.op).comp _ _ (sheafification_adjunction K A)).restrict_fully_faithful
  (Sheaf_to_presheaf J A) (𝟭 _)
  (nat_iso.of_components (λ _, iso.refl _)
    (λ _ _ _,(category.comp_id _).trans (category.id_comp _).symm))
  (nat_iso.of_components (λ _, iso.refl _)
    (λ _ _ _,(category.comp_id _).trans (category.id_comp _).symm))

end category_theory