import category_theory.triangulated.pretriangulated
import category_theory.abelian.exact
import category_theory.linear.yoneda
import algebra.category.Module.abelian
import algebra.category.Group.abelian
import category_theory.functor.currying
import for_mathlib.exact_seq
import for_mathlib.preadditive_yoneda
import for_mathlib.AddCommGroup.exact

import category_theory.abelian.diagram_lemmas.four

namespace category_theory.triangulated

open category_theory
open category_theory.limits
open pretriangulated

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

-- Move me
instance preadditive_yoneda_flip_additive (X : C) :
  (preadditive_yoneda.flip.obj (opposite.op X)).additive :=
by { fsplit, dsimp, intros, ext1, apply preadditive.comp_add }

variables {R : Type*} [ring R] [linear R C]

-- Move me
instance linear_yoneda_flip_additive (X : C) :
  ((linear_yoneda R C).flip.obj (opposite.op X)).additive :=
by { fsplit, dsimp, intros, ext1, dsimp, apply preadditive.comp_add }

variables [has_zero_object C] [has_shift C ℤ] [∀ (n : ℤ), (shift_functor C n).additive]
  [pretriangulated C]

/-- A functor `F` is a *homological* functor if for every distinguished triangle
`A ⟶ B ⟶ C ⟶ A[1]` the sequence `F(A) ⟶ F(B) ⟶ F(C)` is exact. -/
class homological_functor {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive] : Prop :=
(cond [] : ∀ (T : triangle C) (hT : T ∈ dist_triang C), exact (F.map T.mor₁) (F.map T.mor₂))

lemma four_term_exact_seq {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  [homological_functor F] (T : triangle C) (hT : T ∈ dist_triang C):
  exact_seq A [F.map T.mor₁, F.map T.mor₂, F.map T.mor₃] :=
begin
  apply exact_seq.cons,
  apply homological_functor.cond F _ hT,
  rw ← exact_iff_exact_seq,
  apply homological_functor.cond F _ ((rotate_distinguished_triangle T).mp hT),
end

lemma five_term_exact_seq {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  [homological_functor F] (T : triangle C) (hT : T ∈ dist_triang C):
  exact_seq A [F.map T.inv_rotate.mor₁, F.map T.mor₁, F.map T.mor₂, F.map T.mor₃] :=
begin
  apply exact_seq.cons _ _ _ _ (four_term_exact_seq F _ hT),
  apply homological_functor.cond F,
  apply inv_rot_of_dist_triangle _ _ hT,
end

lemma five_term_exact_seq' {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  [homological_functor F] (T : triangle C) (hT : T ∈ dist_triang C) :
  exact_seq A [F.map T.mor₁, F.map T.mor₂, F.map T.mor₃, F.map (T.rotate.mor₃)] :=
begin
  apply exact_seq.cons,
  apply homological_functor.cond F T hT,
  exact four_term_exact_seq F T.rotate (rot_of_dist_triangle _ _ hT),
end

lemma complete_distinguished_triangle_morphism'
  (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ dist_triang C)
  (h₂ : T₂ ∈ dist_triang C)
  (f₂ : T₁.obj₂ ⟶ T₂.obj₂)
  (f₃ : T₁.obj₃ ⟶ T₂.obj₃)
  (w : T₁.mor₂ ≫ f₃ = f₂ ≫ T₂.mor₂) :
  ∃ f₁ : T₁.obj₁ ⟶ T₂.obj₁, (T₁.mor₁ ≫ f₂ = f₁ ≫ T₂.mor₁) ∧ (T₁.mor₃ ≫ f₁⟦1⟧' = f₃ ≫ T₂.mor₃) :=
begin
  let T₁' := T₁.rotate,
  let T₂' := T₂.rotate,
  obtain ⟨g,h1,h2⟩ := complete_distinguished_triangle_morphism T₁' T₂' _ _ f₂ f₃ w,
  use (shift_shift_neg _ _).inv ≫ g⟦(-1 : ℤ)⟧' ≫ (shift_shift_neg _ _).hom,
  split,
  { dsimp at h2,
    apply_fun (λ e, - (shift_functor C (-1 : ℤ)).map e ≫ (shift_shift_neg _ _).hom) at h2,
    simp only [category.assoc, functor.map_comp] at ⊢ h2,
    rw iso.eq_inv_comp,
    convert h2 using 1,
    { simp },
    { simp } },
  { convert h1 using 1,
    congr' 1,
    simp only [functor.map_comp, category.assoc],
    rw shift_neg_shift',
    simp only [category.assoc, ← functor.map_iso_inv, ← functor.map_iso_hom],
    have : (shift_functor C 1).map_iso (shift_shift_neg T₂.obj₁ 1) =
      shift_neg_shift T₂'.obj₃ 1, by { dsimp, simp }, rw this, clear this,
    have : (shift_functor C 1).map_iso (shift_shift_neg T₁.obj₁ (1 : ℤ)) =
      shift_neg_shift ((shift_functor C (1 : ℤ)).obj T₁.obj₁) (1 : ℤ),
      by simp, rw this, clear this,
    simp only [iso.inv_hom_id, iso.inv_hom_id_assoc, category.id_comp, category.comp_id] },
  { rw ← rotate_distinguished_triangle, exact h₁ },
  { rw ← rotate_distinguished_triangle, exact h₂ }
end

theorem dist_triang_to_exact_complex
  (T : triangle C)
  (hT : T ∈ dist_triang C)
  (X : C)
  (f : X ⟶ T.obj₂)
  (hf : f ≫ T.mor₂ = 0) :
  ∃ g : X ⟶ T.obj₁, g ≫ T.mor₁ = f :=
begin
  let I : triangle C := contractible_triangle C X,
  obtain ⟨f₁,h₁,h₂⟩ :=
    complete_distinguished_triangle_morphism' I T
    (contractible_distinguished _) hT f 0
    (by simpa using hf.symm),
  use f₁,
  rw ← h₁,
  dsimp,
  simp,
end

/-- The functor `Y ↦ Hom(X,Y)` is homological. -/
instance preadditive_yoneda_flip_homological (X : C) :
  homological_functor (preadditive_yoneda.flip.obj (opposite.op X)) :=
begin
  constructor,
  intros T hT,
  suffices : add_monoid_hom.range ((preadditive_yoneda.flip.obj (opposite.op X)).map T.mor₁) =
    add_monoid_hom.ker ((preadditive_yoneda.flip.obj (opposite.op X)).map T.mor₂),
  { rwa AddCommGroup.exact_iff },
  apply le_antisymm,
  { rintros _ ⟨(g : X ⟶ _),rfl⟩,
    dsimp,
    obtain ⟨e,h1,he⟩ := complete_distinguished_triangle_morphism
      (contractible_triangle _ X) T (contractible_distinguished _) hT g (g ≫ T.mor₁)
      (by { dsimp, simp }),
    dsimp at he,
    simp only [zero_comp] at he,
    change _ = _,
    simp [← h1] },
  { rintros (f : X ⟶ _) (hf : f ≫ _ = 0),
    apply dist_triang_to_exact_complex _ hT _ _ hf }
end

/-- The functor `Y ↦ Hom(Y,X)` is homological. -/
instance preadditive_yoneda_op_homological (X : C) :
  homological_functor (preadditive_yoneda.obj X).right_op :=
begin
  constructor,
  intros T hT,
  dsimp,
  let f := _, let g := _, show exact f g,
  suffices : exact g.unop f.unop,
  { rw ← f.op_unop, rw ← g.op_unop, apply this.op, },
  rw AddCommGroup.exact_iff,
  apply le_antisymm,
  { rintros _ ⟨q : _ ⟶ X, rfl⟩,
    change _ ≫ _ = 0,
    dsimp,
    have := complete_distinguished_triangle_morphism
      T.rotate (contractible_triangle _ X) _
      (contractible_distinguished _) (T.mor₂ ≫ q) q (by { dsimp, simp }),
    swap, rwa ← rotate_distinguished_triangle,
    obtain ⟨c,h1,h2⟩ := this,
    dsimp at h2,
    simp at h2,
    simp only [← functor.map_comp] at h2,
    rw ← (shift_functor C (1 : ℤ)).map_zero at h2,
    exact (shift_functor C (1 : ℤ)).map_injective h2 },
  { rintros (q : _ ⟶ X) (hq : _ ≫ _ = 0),
    change ∃ p, _,
    dsimp at hq ⊢,
    obtain ⟨c,h1,h2⟩ := complete_distinguished_triangle_morphism
      T (contractible_triangle _ X).inv_rotate hT _ 0 q (by simp [hq]),
    { use c,
      simp only [h1, triangle.inv_rotate_mor₂, contractible_triangle_mor₁],
      erw category.comp_id },
    { apply inv_rot_of_dist_triangle, apply contractible_distinguished } },
end

-- Prove this using the above theorem.
instance linear_yoneda_flip_homological (X : C) :
  homological_functor ((linear_yoneda R C).flip.obj (opposite.op X)) :=
begin
  constructor,
  intros T hT,
  rw Module.exact_iff,
  apply le_antisymm,
  { rintros _ ⟨(g : X ⟶ _),rfl⟩,
    dsimp,
    obtain ⟨e,h1,he⟩ := complete_distinguished_triangle_morphism
      (contractible_triangle _ X) T (contractible_distinguished _) hT g (g ≫ T.mor₁)
      (by { dsimp, simp }),
    dsimp at he,
    simp only [zero_comp] at he,
    simp [← h1] },
  { rintros (f : X ⟶ _) (hf : f ≫ _ = 0),
    apply dist_triang_to_exact_complex _ hT _ _ hf }
end

lemma is_iso_triangle_hom_of_is_iso (T₁ T₂ : triangle C)
  (e : T₁ ⟶ T₂)
  [is_iso e.hom₁]
  [is_iso e.hom₂]
  [is_iso e.hom₃] : is_iso e :=
begin
  constructor,
  refine ⟨⟨inv e.hom₁, inv e.hom₂, inv e.hom₃, _, _⟩, _, _⟩,
  { dsimp,
    rw [is_iso.comp_inv_eq, category.assoc, is_iso.eq_inv_comp, e.comm₁] },
  { dsimp,
    rw [is_iso.comp_inv_eq, category.assoc, is_iso.eq_inv_comp, e.comm₂] },
  { ext; dsimp; simp },
  { ext; dsimp; simp },
end

lemma is_iso_of_is_iso_rotate (T₁ T₂ : triangle C)
  (e : T₁ ⟶ T₂) [h : is_iso ((rotate C).map e)] : is_iso e :=
begin
  haveI : is_iso ((triangle_rotation C).functor.map e) := h,
  apply is_iso_of_fully_faithful ((triangle_rotation C).functor : triangle C ⥤ triangle C),
end

lemma is_iso_of_is_iso_inv_rotate (T₁ T₂ : triangle C)
  (e : T₁ ⟶ T₂) [h : is_iso ((inv_rotate C).map e)] : is_iso e :=
begin
  haveI : is_iso ((triangle_rotation C).inverse.map e) := h,
  apply is_iso_of_fully_faithful ((triangle_rotation C).inverse : triangle C ⥤ triangle C),
end

theorem is_iso_of_is_iso_of_is_iso (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ dist_triang C) (h₂ : T₂ ∈ dist_triang C)
  (e : T₁ ⟶ T₂) [is_iso e.hom₁] [is_iso e.hom₃] : is_iso e :=
begin
  apply_with is_iso_triangle_hom_of_is_iso { instances := ff },
  any_goals { apply_instance },
  apply_instance,

  apply_with is_iso_of_is_iso_preadditive_yoneda_map_app { instances := ff },
  swap, apply_instance,
  intros W,

  let Y := (preadditive_yoneda.flip.obj (opposite.op W)),

  have H1 := five_term_exact_seq Y _ h₁,
  have H2 := five_term_exact_seq Y _ h₂,

  have sq1 := e.inv_rotate.comm₁,
  apply_fun (λ e, Y.map e) at sq1,
  simp only [functor.map_comp] at sq1,

  have sq2 := e.comm₁,
  apply_fun (λ e, Y.map e) at sq2,
  simp only [functor.map_comp] at sq2,

  have sq3 := e.comm₂,
  apply_fun (λ e, Y.map e) at sq3,
  simp only [functor.map_comp] at sq3,

  have sq4 := e.comm₃,
  apply_fun (λ e, Y.map e) at sq4,
  simp only [functor.map_comp] at sq4,

  haveI : is_iso (Y.map (triangulated.triangle_morphism.inv_rotate e).hom₁),
  { dsimp only [triangulated.triangle_morphism.inv_rotate],
    rw ← functor.comp_map,
    apply functor.map_is_iso },

  haveI : is_iso (Y.map (triangulated.triangle_morphism.inv_rotate e).hom₂),
  { dsimp only [triangulated.triangle_morphism.inv_rotate],
    apply functor.map_is_iso },

  haveI : is_iso (Y.map e.hom₃),
  { apply functor.map_is_iso },

  haveI : is_iso (Y.map ((shift_functor C (1 : ℤ)).map e.hom₁)),
  { rw ← functor.comp_map,
    apply functor.map_is_iso },

  exact @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso _ _ _
    _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
    sq1.symm sq2.symm sq3.symm _ _ _ _ _ sq4.symm
    ((exact_iff_exact_seq _ _).mpr (H1.extract 0 2))
    ((exact_iff_exact_seq _ _).mpr (H1.extract 1 2))
    ((exact_iff_exact_seq _ _).mpr (H1.extract 2 3))
    ((exact_iff_exact_seq _ _).mpr (H2.extract 0 2))
    ((exact_iff_exact_seq _ _).mpr (H2.extract 1 2))
    ((exact_iff_exact_seq _ _).mpr (H2.extract 2 3)) _ _ _ _,
end

lemma is_iso_of_is_iso_of_is_iso' (T₁ T₂ : triangle C)
  (h₁ : T₁ ∈ dist_triang C) (h₂ : T₂ ∈ dist_triang C)
  (e : T₁ ⟶ T₂) [h1 : is_iso e.hom₁] [h2 : is_iso e.hom₂] : is_iso e :=
begin
  suffices : is_iso ((rotate C).map e),
  { resetI, apply is_iso_of_is_iso_rotate },
  haveI : is_iso ((rotate C).map e).hom₁ := h2,
  haveI : is_iso ((rotate C).map e).hom₃,
  { apply functor.map_is_iso },
  apply is_iso_of_is_iso_of_is_iso,
  all_goals { erw ← rotate_distinguished_triangle, assumption },
end

instance is_iso_hom₁ (T₁ T₂ : triangle C) (e : T₁ ⟶ T₂) [is_iso e] :
  is_iso e.hom₁ :=
⟨⟨(inv e).hom₁,
  show (e ≫ inv e).hom₁ = _, by simpa only [is_iso.hom_inv_id],
  show (inv e ≫ e).hom₁ = _, by simpa only [is_iso.inv_hom_id]⟩⟩

instance is_iso_hom₂ (T₁ T₂ : triangle C) (e : T₁ ⟶ T₂) [is_iso e] :
  is_iso e.hom₂ :=
⟨⟨(inv e).hom₂,
  show (e ≫ inv e).hom₂ = _, by simpa only [is_iso.hom_inv_id],
  show (inv e ≫ e).hom₂ = _, by simpa only [is_iso.inv_hom_id]⟩⟩

instance is_iso_hom₃ (T₁ T₂ : triangle C) (e : T₁ ⟶ T₂) [is_iso e] :
  is_iso e.hom₃ :=
⟨⟨(inv e).hom₃,
  show (e ≫ inv e).hom₃ = _, by simpa only [is_iso.hom_inv_id],
  show (inv e ≫ e).hom₃ = _, by simpa only [is_iso.inv_hom_id]⟩⟩

lemma homological_of_exists_aux {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  (T₁ T₂ : triangle C) (e : T₁ ⟶ T₂) [is_iso e] (H : exact (F.map T₁.mor₁) (F.map T₁.mor₂)) :
  exact (F.map T₂.mor₁) (F.map T₂.mor₂) :=
begin
  have : T₂.mor₁ = inv e.hom₁ ≫ T₁.mor₁ ≫ e.hom₂,
  { rw is_iso.eq_inv_comp,
    exact e.comm₁.symm },
  rw this, clear this,
  have : T₂.mor₂ = inv e.hom₂ ≫ T₁.mor₂ ≫ e.hom₃,
  { rw is_iso.eq_inv_comp,
    exact e.comm₂.symm },
  rw this, clear this,
  simp only [F.map_comp, F.map_inv],
  simp only [exact_iso_comp],
  simp only [← category.assoc],
  simp only [exact_comp_iso],
  change exact (_ ≫ (as_iso (F.map e.hom₂)).hom) ((as_iso (F.map e.hom₂)).inv ≫ _),
  rwa exact_comp_hom_inv_comp_iff,
end

lemma homological_of_exists {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  (h : ∀ (X Y : C) (f : X ⟶ Y),
    (∃ (Z : C) (g : Y ⟶ Z) (h : Z ⟶ X⟦(1 : ℤ)⟧) (hT : triangle.mk _ f g h ∈ dist_triang C),
    exact (F.map f) (F.map g))) : homological_functor F :=
begin
  constructor,
  intros T hT,
  specialize h T.obj₁ T.obj₂ T.mor₁,
  obtain ⟨Z,g,h,hT',hE⟩ := h,
  let T' := triangle.mk _ T.mor₁ g h,
  obtain ⟨e,h1,h2⟩ := complete_distinguished_triangle_morphism T' T hT' hT (𝟙 _) (𝟙 _) (by simp),
  let E : T' ⟶ T := ⟨𝟙 _, 𝟙 _, e, by simp, h1⟩,
  haveI : is_iso E,
  { apply is_iso_of_is_iso_of_is_iso' _ _ hT' hT },
  exact homological_of_exists_aux F T' T E hE,
end

lemma homological_of_rotate {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  (h : ∀ (T : triangle C) (hT : T ∈ dist_triang C),
    exact (F.map T.rotate.mor₁) (F.map T.rotate.mor₂)) : homological_functor F :=
begin
  constructor,
  intros T hT,
  specialize h T.inv_rotate (inv_rot_of_dist_triangle C T hT),
  let E : T.inv_rotate.rotate ≅ T := inv_rot_comp_rot.app _,
  apply homological_of_exists_aux _ _ _ E.hom,
  assumption'
end

lemma homological_of_inv_rotate {A : Type*} [category A] [abelian A] (F : C ⥤ A) [F.additive]
  (h : ∀ (T : triangle C) (hT : T ∈ dist_triang C),
    exact (F.map T.inv_rotate.mor₁) (F.map T.inv_rotate.mor₂)) : homological_functor F :=
begin
  constructor,
  intros T hT,
  specialize h T.rotate (rot_of_dist_triangle C T hT),
  let E : T.rotate.inv_rotate ≅ T := (rot_comp_inv_rot.app _).symm,
  apply homological_of_exists_aux _ _ _ E.hom,
  assumption'
end

lemma homological_of_nat_iso {A : Type*} [category A] [abelian A] (F G : C ⥤ A)
  [F.additive] [G.additive] [homological_functor F] (e : F ≅ G) : homological_functor G :=
begin
  constructor,
  intros T hT,
  have h₁ := e.hom.naturality T.mor₁,
  have h₂ := e.hom.naturality T.mor₂,
  rw ← is_iso.inv_comp_eq at h₁ h₂,
  rw [← h₁, ← h₂, exact_iso_comp, ← category.assoc, exact_comp_iso],
  let E := as_iso (e.hom.app T.obj₂),
  change exact (F.map T.mor₁ ≫ E.hom) (E.inv ≫ _),
  have : exact (F.map T.mor₁) (F.map T.mor₂) := by apply homological_functor.cond F _ hT,
  rwa exact_comp_hom_inv_comp_iff,
end

end category_theory.triangulated


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Simon Hudon
-/
import category_theory.monoidal.braided
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.terminal
import category_theory.pempty

/-!
# The monoidal structure on a category with chosen finite products.

This is a variant of the development in `category_theory.monoidal.of_has_finite_products`,
which uses specified choices of the terminal object and binary product,
enabling the construction of a cartesian category with specific definitions of the tensor unit
and tensor product.

(Because the construction in `category_theory.monoidal.of_has_finite_products` uses `has_limit`
classes, the actual definitions there are opaque behind `classical.choice`.)

We use this in `category_theory.monoidal.types` to construct the monoidal category of types
so that the tensor product is the usual cartesian product of types.

For now we only do the construction from products, and not from coproducts,
which seems less often useful.
-/

universes v u

noncomputable theory

namespace category_theory

variables (C : Type u) [category.{v} C] {X Y : C}

namespace limits

section
variables {C}

/-- Swap the two sides of a `binary_fan`. -/
def binary_fan.swap {P Q : C} (t : binary_fan P Q) : binary_fan Q P :=
binary_fan.mk t.snd t.fst

@[simp] lemma binary_fan.swap_fst {P Q : C} (t : binary_fan P Q) : t.swap.fst = t.snd := rfl
@[simp] lemma binary_fan.swap_snd {P Q : C} (t : binary_fan P Q) : t.swap.snd = t.fst := rfl

/--
If a cone `t` over `P Q` is a limit cone, then `t.swap` is a limit cone over `Q P`.
-/
@[simps]
def is_limit.swap_binary_fan {P Q : C} {t : binary_fan P Q} (I : is_limit t) : is_limit t.swap :=
{ lift := λ s, I.lift (binary_fan.swap s),
  fac' := λ s, by { rintro ⟨⟨⟩⟩; simp, },
  uniq' := λ s m w,
  begin
    have h := I.uniq (binary_fan.swap s) m,
    rw h,
    rintro ⟨j⟩,
    specialize w ⟨j.swap⟩,
    cases j; exact w,
  end }

/--
Construct `has_binary_product Q P` from `has_binary_product P Q`.
This can't be an instance, as it would cause a loop in typeclass search.
-/
lemma has_binary_product.swap (P Q : C) [has_binary_product P Q] : has_binary_product Q P :=
has_limit.mk ⟨binary_fan.swap (limit.cone (pair P Q)), (limit.is_limit (pair P Q)).swap_binary_fan⟩

/--
Given a limit cone over `X` and `Y`, and another limit cone over `Y` and `X`, we can construct
an isomorphism between the cone points. Relative to some fixed choice of limits cones for every
pair, these isomorphisms constitute a braiding.
-/
def binary_fan.braiding {X Y : C}
  {s : binary_fan X Y} (P : is_limit s) {t : binary_fan Y X} (Q : is_limit t) :
  s.X ≅ t.X :=
is_limit.cone_point_unique_up_to_iso P Q.swap_binary_fan

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `sXY.X Z`,
if `sYZ` is a limit cone we can construct a binary fan over `X sYZ.X`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  binary_fan X sYZ.X :=
binary_fan.mk (s.fst ≫ sXY.fst) (Q.lift (binary_fan.mk (s.fst ≫ sXY.snd) s.snd))

@[simp] lemma binary_fan.assoc_fst {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  (s.assoc Q).fst = s.fst ≫ sXY.fst := rfl
@[simp] lemma binary_fan.assoc_snd {X Y Z : C}
  {sXY : binary_fan X Y} {sYZ : binary_fan Y Z} (Q : is_limit sYZ) (s : binary_fan sXY.X Z) :
  (s.assoc Q).snd = Q.lift (binary_fan.mk (s.fst ≫ sXY.snd) s.snd) := rfl

/--
Given binary fans `sXY` over `X Y`, and `sYZ` over `Y Z`, and `s` over `X sYZ.X`,
if `sYZ` is a limit cone we can construct a binary fan over `sXY.X Z`.

This is an ingredient of building the associator for a cartesian category.
-/
def binary_fan.assoc_inv {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  binary_fan sXY.X Z :=
binary_fan.mk (P.lift (binary_fan.mk s.fst (s.snd ≫ sYZ.fst))) (s.snd ≫ sYZ.snd)

@[simp] lemma binary_fan.assoc_inv_fst {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  (s.assoc_inv P).fst = P.lift (binary_fan.mk s.fst (s.snd ≫ sYZ.fst)) := rfl
@[simp] lemma binary_fan.assoc_inv_snd {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (s : binary_fan X sYZ.X) :
  (s.assoc_inv P).snd = s.snd ≫ sYZ.snd := rfl

/--
If all the binary fans involved a limit cones, `binary_fan.assoc` produces another limit cone.
-/
@[simps]
def is_limit.assoc {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ)
  {s : binary_fan sXY.X Z} (R : is_limit s) : is_limit (s.assoc Q) :=
{ lift := λ t, R.lift (binary_fan.assoc_inv P t),
  fac' := λ t,
  begin
    rintro ⟨⟨⟩⟩; simp,
    apply Q.hom_ext,
    rintro ⟨⟨⟩⟩; simp,
  end,
  uniq' := λ t m w,
  begin
    have h := R.uniq (binary_fan.assoc_inv P t) m,
    rw h,
    rintro ⟨⟨⟩⟩; simp,
    apply P.hom_ext,
    rintro ⟨⟨⟩⟩; simp,
    { exact w ⟨walking_pair.left⟩, },
    { specialize w ⟨walking_pair.right⟩,
      simp at w,
      rw [←w], simp, },
    { specialize w ⟨walking_pair.right⟩,
      simp at w,
      rw [←w], simp, },
  end, }

/--
Given two pairs of limit cones corresponding to the parenthesisations of `X × Y × Z`,
we obtain an isomorphism between the cone points.
-/
@[reducible]
def binary_fan.associator {X Y Z : C}
  {sXY : binary_fan X Y} (P : is_limit sXY) {sYZ : binary_fan Y Z} (Q : is_limit sYZ)
  {s : binary_fan sXY.X Z} (R : is_limit s) {t : binary_fan X sYZ.X} (S : is_limit t) :
  s.X ≅ t.X :=
is_limit.cone_point_unique_up_to_iso (is_limit.assoc P Q R) S

/--
Given a fixed family of limit data for every pair `X Y`, we obtain an associator.
-/
@[reducible]
def binary_fan.associator_of_limit_cone
  (L : Π X Y : C, limit_cone (pair X Y)) (X Y Z : C) :
  (L (L X Y).cone.X Z).cone.X ≅ (L X (L Y Z).cone.X).cone.X :=
binary_fan.associator
  (L X Y).is_limit (L Y Z).is_limit
  (L (L X Y).cone.X Z).is_limit (L X (L Y Z).cone.X).is_limit

local attribute [tidy] tactic.discrete_cases

/--
Construct a left unitor from specified limit cones.
-/
@[simps]
def binary_fan.left_unitor {X : C} {s : cone (functor.empty.{v} C)} (P : is_limit s)
  {t : binary_fan s.X X} (Q : is_limit t) : t.X ≅ X :=
{ hom := t.snd,
  inv := Q.lift (binary_fan.mk (P.lift
    { X := X, π := { app := discrete.rec (pempty.rec _) } }) (𝟙 X) ),
  hom_inv_id' :=
  by { apply Q.hom_ext, rintro ⟨⟨⟩⟩, { apply P.hom_ext, rintro ⟨⟨⟩⟩, }, { simp, }, }, }

/--
Construct a right unitor from specified limit cones.
-/
@[simps]
def binary_fan.right_unitor {X : C} {s : cone (functor.empty.{v} C)} (P : is_limit s)
  {t : binary_fan X s.X} (Q : is_limit t) : t.X ≅ X :=
{ hom := t.fst,
  inv := Q.lift (binary_fan.mk (𝟙 X) (P.lift
    { X := X, π := { app := discrete.rec (pempty.rec _) } })),
  hom_inv_id' :=
  by { apply Q.hom_ext, rintro ⟨⟨⟩⟩, { simp, }, { apply P.hom_ext, rintro ⟨⟨⟩⟩, }, }, }

end

end limits

open category_theory.limits

section
local attribute [tidy] tactic.case_bash

variables {C}
variables (𝒯 : limit_cone (functor.empty.{v} C))
variables (ℬ : Π (X Y : C), limit_cone (pair X Y))

namespace monoidal_of_chosen_finite_products

/-- Implementation of the tensor product for `monoidal_of_chosen_finite_products`. -/
@[reducible]
def tensor_obj (X Y : C) : C := (ℬ X Y).cone.X

/-- Implementation of the tensor product of morphisms for `monoidal_of_chosen_finite_products`. -/
@[reducible]
def tensor_hom {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) : tensor_obj ℬ W Y ⟶ tensor_obj ℬ X Z :=
  (binary_fan.is_limit.lift' (ℬ X Z).is_limit
    ((ℬ W Y).cone.π.app ⟨walking_pair.left⟩ ≫ f)
    (((ℬ W Y).cone.π.app ⟨walking_pair.right⟩ : (ℬ W Y).cone.X ⟶ Y) ≫ g)).val

lemma tensor_id (X₁ X₂ : C) : tensor_hom ℬ (𝟙 X₁) (𝟙 X₂) = 𝟙 (tensor_obj ℬ X₁ X₂) :=
begin
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩;
  { dsimp [tensor_hom], simp, },
end

lemma tensor_comp {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂) :
  tensor_hom ℬ (f₁ ≫ g₁) (f₂ ≫ g₂) =
    tensor_hom ℬ f₁ f₂ ≫ tensor_hom ℬ g₁ g₂ :=
begin
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩;
  { dsimp [tensor_hom], simp, },
end

lemma pentagon (W X Y Z : C) :
  tensor_hom ℬ (binary_fan.associator_of_limit_cone ℬ W X Y).hom (𝟙 Z) ≫
    (binary_fan.associator_of_limit_cone ℬ W (tensor_obj ℬ X Y) Z).hom ≫
      tensor_hom ℬ (𝟙 W) (binary_fan.associator_of_limit_cone ℬ X Y Z).hom =
  (binary_fan.associator_of_limit_cone ℬ (tensor_obj ℬ W X) Y Z).hom ≫
    (binary_fan.associator_of_limit_cone ℬ W X (tensor_obj ℬ Y Z)).hom :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
  { simp, },
  { apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
    { simp, },
    apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
    { simp, },
    { simp, }, }
end

lemma triangle (X Y : C) :
  (binary_fan.associator_of_limit_cone ℬ X 𝒯.cone.X Y).hom ≫
    tensor_hom ℬ (𝟙 X) (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X Y).is_limit).hom =
  tensor_hom ℬ (binary_fan.right_unitor 𝒯.is_limit (ℬ X 𝒯.cone.X).is_limit).hom (𝟙 Y) :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩; simp,
end

lemma left_unitor_naturality {X₁ X₂ : C} (f : X₁ ⟶ X₂) :
  tensor_hom ℬ (𝟙 𝒯.cone.X) f ≫ (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X X₂).is_limit).hom =
    (binary_fan.left_unitor 𝒯.is_limit (ℬ 𝒯.cone.X X₁).is_limit).hom ≫ f :=
begin
  dsimp [tensor_hom],
  simp,
end

lemma right_unitor_naturality {X₁ X₂ : C} (f : X₁ ⟶ X₂) :
  tensor_hom ℬ f (𝟙 𝒯.cone.X) ≫
    (binary_fan.right_unitor 𝒯.is_limit (ℬ X₂ 𝒯.cone.X).is_limit).hom =
    (binary_fan.right_unitor 𝒯.is_limit (ℬ X₁ 𝒯.cone.X).is_limit).hom ≫ f :=
begin
  dsimp [tensor_hom],
  simp,
end

lemma associator_naturality {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃) :
  tensor_hom ℬ (tensor_hom ℬ f₁ f₂) f₃ ≫ (binary_fan.associator_of_limit_cone ℬ Y₁ Y₂ Y₃).hom =
    (binary_fan.associator_of_limit_cone ℬ X₁ X₂ X₃).hom ≫
      tensor_hom ℬ f₁ (tensor_hom ℬ f₂ f₃) :=
begin
  dsimp [tensor_hom],
  apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
  { simp, },
  { apply is_limit.hom_ext (ℬ _ _).is_limit, rintro ⟨⟨⟩⟩,
    { simp, },
    { simp, }, },
end

end monoidal_of_chosen_finite_products

open monoidal_of_chosen_finite_products

/-- A category with a terminal object and binary products has a natural monoidal structure. -/
def monoidal_of_chosen_finite_products :
  monoidal_category C :=
{ tensor_unit  := 𝒯.cone.X,
  tensor_obj   := λ X Y, tensor_obj ℬ X Y,
  tensor_hom   := λ _ _ _ _ f g, tensor_hom ℬ f g,
  tensor_id'   := tensor_id ℬ,
  tensor_comp' := λ _ _ _ _ _ _ f₁ f₂ g₁ g₂, tensor_comp ℬ f₁ f₂ g₁ g₂,
  associator   := λ X Y Z, binary_fan.associator_of_limit_cone ℬ X Y Z,
  left_unitor  := λ X, binary_fan.left_unitor (𝒯.is_limit) (ℬ 𝒯.cone.X X).is_limit,
  right_unitor := λ X, binary_fan.right_unitor (𝒯.is_limit) (ℬ X 𝒯.cone.X).is_limit,
  pentagon'    := pentagon ℬ,
  triangle'    := triangle 𝒯 ℬ,
  left_unitor_naturality' := λ _ _ f, left_unitor_naturality 𝒯 ℬ f,
  right_unitor_naturality' := λ _ _ f, right_unitor_naturality 𝒯 ℬ f,
  associator_naturality' := λ _ _ _ _ _ _ f₁ f₂ f₃, associator_naturality ℬ f₁ f₂ f₃, }

namespace monoidal_of_chosen_finite_products

open monoidal_category

/--
A type synonym for `C` carrying a monoidal category structure corresponding to
a fixed choice of limit data for the empty functor, and for `pair X Y` for every `X Y : C`.

This is an implementation detail for `symmetric_of_chosen_finite_products`.
-/
@[derive category, nolint unused_arguments has_inhabited_instance]
def monoidal_of_chosen_finite_products_synonym
  (𝒯 : limit_cone (functor.empty.{v} C)) (ℬ : Π (X Y : C), limit_cone (pair X Y)):= C

instance : monoidal_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
monoidal_of_chosen_finite_products 𝒯 ℬ

lemma braiding_naturality {X X' Y Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') :
  (tensor_hom ℬ f g) ≫ (limits.binary_fan.braiding (ℬ Y Y').is_limit (ℬ Y' Y).is_limit).hom =
    (limits.binary_fan.braiding (ℬ X X').is_limit (ℬ X' X).is_limit).hom ≫ (tensor_hom ℬ g f) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩;
  { dsimp [limits.is_limit.cone_point_unique_up_to_iso], simp, },
end

lemma hexagon_reverse (X Y Z : C) :
  (binary_fan.associator_of_limit_cone ℬ X Y Z).inv ≫
    (limits.binary_fan.braiding
      (ℬ (tensor_obj ℬ X Y) Z).is_limit
      (ℬ Z (tensor_obj ℬ X Y)).is_limit).hom ≫
    (binary_fan.associator_of_limit_cone ℬ Z X Y).inv =
    (tensor_hom ℬ (𝟙 X) (limits.binary_fan.braiding (ℬ Y Z).is_limit (ℬ Z Y).is_limit).hom) ≫
      (binary_fan.associator_of_limit_cone ℬ X Z Y).inv ≫
        (tensor_hom ℬ (limits.binary_fan.braiding (ℬ X Z).is_limit (ℬ Z X).is_limit).hom (𝟙 Y)) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩,
  { apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩;
    { dsimp [binary_fan.associator_of_limit_cone, binary_fan.associator,
        limits.is_limit.cone_point_unique_up_to_iso],
      simp, }, },
  { dsimp [binary_fan.associator_of_limit_cone, binary_fan.associator,
      limits.is_limit.cone_point_unique_up_to_iso],
    simp, },
end

lemma symmetry (X Y : C) :
  (limits.binary_fan.braiding (ℬ X Y).is_limit (ℬ Y X).is_limit).hom ≫
      (limits.binary_fan.braiding (ℬ Y X).is_limit (ℬ X Y).is_limit).hom =
    𝟙 (tensor_obj ℬ X Y) :=
begin
  dsimp [tensor_hom, limits.binary_fan.braiding],
  apply (ℬ _ _).is_limit.hom_ext, rintro ⟨⟨⟩⟩;
  { dsimp [limits.is_limit.cone_point_unique_up_to_iso], simp, },
end

end monoidal_of_chosen_finite_products

open monoidal_of_chosen_finite_products

/--
The monoidal structure coming from finite products is symmetric.
-/
def symmetric_of_chosen_finite_products :
  symmetric_category (monoidal_of_chosen_finite_products_synonym 𝒯 ℬ) :=
{ braiding := λ X Y, limits.binary_fan.braiding (ℬ _ _).is_limit (ℬ _ _).is_limit,
  braiding_naturality' := λ X X' Y Y' f g, braiding_naturality ℬ f g,
  hexagon_forward' := λ X Y Z, hexagon_forward ℬ X Y Z,
  hexagon_reverse' := λ X Y Z, hexagon_reverse ℬ X Y Z,
  symmetry' := λ X Y, symmetry ℬ X Y, }

end

end category_theory


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.morphisms.basic
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 [← set_like.coe_subset_coe],
    dsimp,
    simp only [set.image_univ, subtype.range_coe, set.image_subset_iff],
    refl },
  { 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_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

end ring_hom.property_is_local


/-
Here is an artificial example where temporary metavariables created by typeclass resolution
would otherwise leak into nested typeclass resolution unless we catch it.
-/

class Foo  (α : Type) : Type := (x : Unit)
class Bar  (α : Type) : Type := (x : Unit)
class HasParam (α : Type) [Bar α] : Type := (x : Unit)

instance FooToBar (α : Type) [Foo α] : Bar α := {x:=()}

-- Note: there is an implicit `FooToBar` inside the second argument of the return type.
instance HasParamInst (α : Type) [h : Foo α] : HasParam α := {x:=()}

class Top : Type := (x : Unit)

-- Note: `AllFoo` is a weird, universal instance.
instance AllFoo (α : Type) : Foo α := {x:=()}

/-
When the subgoal `[@HasParam α (@FooToBar α (AllFoo α))]` is triggerred, `α` is not known.

This happens for two reasons:

1. The return type `Top` does not include `α`.
2. The universal `AllFoo α` instance obviates the need to take a building-block class as argument.

Thus we would be tempted to call nested typeclass resolution on `Foo <tmp-mvar>`.
-/
instance Bad (α : Type) [HasParam α] : Top := Top.mk ()
def foo [Top] : Unit := ()

set_option pp.all true
set_option trace.class_instances true
set_option trace.type_context.complete_instance true

#check @foo _

/-
[class_instances]  class-instance resolution trace
[class_instances] (0) ?x_0 : Top := @Bad ?x_1 ?x_2
[class_instances] (1) ?x_2 : @HasParam ?x_1 (@FooToBar ?x_1 (AllFoo ?x_1)) := @HasParamInst ?x_3 ?x_4
[type_context.complete_instance] would have synthed: Foo ?x_3
-/


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import category_theory.category.Cat
import category_theory.category.preorder
import category_theory.concrete_category.bundled_hom
import order.hom.basic

/-!
# Category of preorders

This defines `Preord`, the category of preorders with monotone maps.
-/

universe u

open category_theory

/-- The category of preorders. -/
def Preord := bundled preorder

namespace Preord

instance : bundled_hom @order_hom :=
{ to_fun := @order_hom.to_fun,
  id := @order_hom.id,
  comp := @order_hom.comp,
  hom_ext := @order_hom.ext }

attribute [derive [large_category, concrete_category]] Preord

instance : has_coe_to_sort Preord Type* := bundled.has_coe_to_sort

/-- Construct a bundled Preord from the underlying type and typeclass. -/
def of (α : Type*) [preorder α] : Preord := bundled.of α

@[simp] lemma coe_of (α : Type*) [preorder α] : ↥(of α) = α := rfl

instance : inhabited Preord := ⟨of punit⟩

instance (α : Preord) : preorder α := α.str

/-- Constructs an equivalence between preorders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : Preord.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : Preord ⥤ Preord :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, order_hom.dual }

/-- The equivalence between `Preord` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : Preord ≌ Preord :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end Preord

/--
The embedding of `Preord` into `Cat`.
-/
@[simps]
def Preord_to_Cat : Preord.{u} ⥤ Cat :=
{ obj := λ X, Cat.of X.1,
  map := λ X Y f, f.monotone.functor,
  map_id' := λ X, begin apply category_theory.functor.ext, tidy end,
  map_comp' := λ X Y Z f g, begin apply category_theory.functor.ext, tidy end }

instance : faithful Preord_to_Cat.{u} :=
{ map_injective' := λ X Y f g h, begin ext x, exact functor.congr_obj h x end }

instance : full Preord_to_Cat.{u} :=
{ preimage := λ X Y f, ⟨f.obj, f.monotone⟩,
  witness' := λ X Y f, begin apply category_theory.functor.ext, tidy end }