/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module algebra.module.ulift
! leanprover-community/mathlib commit 68d1483e8a718ec63219f0e227ca3f0140361086
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Ring.Ulift
import Mathbin.Algebra.Module.Equiv

/-!
# `ulift` instances for module and multiplicative actions

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

This file defines instances for module, mul_action and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We also provide `ulift.module_equiv : ulift M ≃ₗ[R] M`.

-/

namespace ULift

universe u v w

variable {R : Type u}

variable {M : Type v}

variable {N : Type w}

#print ULift.smulLeft /-
@[to_additive]
instance smulLeft [SMul R M] : SMul (ULift R) M :=
  ⟨fun s x => s.down • x⟩
#align ulift.has_smul_left ULift.smulLeft
#align ulift.has_vadd_left ULift.vaddLeft
-/

/- warning: ulift.smul_def -> ULift.smul_def is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {M : Type.{u2}} [_inst_1 : SMul.{u1, u2} R M] (s : ULift.{u3, u1} R) (x : M), Eq.{succ u2} M (SMul.smul.{max u1 u3, u2} (ULift.{u3, u1} R) M (ULift.smulLeft.{u1, u2, u3} R M _inst_1) s x) (SMul.smul.{u1, u2} R M _inst_1 (ULift.down.{u3, u1} R s) x)
but is expected to have type
  forall {R : Type.{u2}} {M : Type.{u3}} [_inst_1 : SMul.{u2, u3} R M] (s : ULift.{u1, u2} R) (x : M), Eq.{succ u3} M (HSMul.hSMul.{max u2 u1, u3, u3} (ULift.{u1, u2} R) M M (instHSMul.{max u2 u1, u3} (ULift.{u1, u2} R) M (ULift.smulLeft.{u2, u3, u1} R M _inst_1)) s x) (HSMul.hSMul.{u2, u3, u3} R M M (instHSMul.{u2, u3} R M _inst_1) (ULift.down.{u1, u2} R s) x)
Case conversion may be inaccurate. Consider using '#align ulift.smul_def ULift.smul_defₓ'. -/
@[simp, to_additive]
theorem smul_def [SMul R M] (s : ULift R) (x : M) : s • x = s.down • x :=
  rfl
#align ulift.smul_def ULift.smul_def
#align ulift.vadd_def ULift.vadd_def

#print ULift.isScalarTower /-
instance isScalarTower [SMul R M] [SMul M N] [SMul R N] [IsScalarTower R M N] :
    IsScalarTower (ULift R) M N :=
  ⟨fun x y z => show (x.down • y) • z = x.down • y • z from smul_assoc _ _ _⟩
#align ulift.is_scalar_tower ULift.isScalarTower
-/

#print ULift.isScalarTower' /-
instance isScalarTower' [SMul R M] [SMul M N] [SMul R N] [IsScalarTower R M N] :
    IsScalarTower R (ULift M) N :=
  ⟨fun x y z => show (x • y.down) • z = x • y.down • z from smul_assoc _ _ _⟩
#align ulift.is_scalar_tower' ULift.isScalarTower'
-/

#print ULift.isScalarTower'' /-
instance isScalarTower'' [SMul R M] [SMul M N] [SMul R N] [IsScalarTower R M N] :
    IsScalarTower R M (ULift N) :=
  ⟨fun x y z => show up ((x • y) • z.down) = ⟨x • y • z.down⟩ by rw [smul_assoc]⟩
#align ulift.is_scalar_tower'' ULift.isScalarTower''
-/

instance [SMul R M] [SMul Rᵐᵒᵖ M] [IsCentralScalar R M] : IsCentralScalar R (ULift M) :=
  ⟨fun r m => congr_arg up <| op_smul_eq_smul r m.down⟩

#print ULift.mulAction /-
@[to_additive]
instance mulAction [Monoid R] [MulAction R M] : MulAction (ULift R) M
    where
  smul := (· • ·)
  mul_smul _ _ := mul_smul _ _
  one_smul := one_smul _
#align ulift.mul_action ULift.mulAction
#align ulift.add_action ULift.addAction
-/

#print ULift.mulAction' /-
@[to_additive]
instance mulAction' [Monoid R] [MulAction R M] : MulAction R (ULift M)
    where
  smul := (· • ·)
  mul_smul := fun r s ⟨f⟩ => ext _ _ <| mul_smul _ _ _
  one_smul := fun ⟨f⟩ => ext _ _ <| one_smul _ _
#align ulift.mul_action' ULift.mulAction'
#align ulift.add_action' ULift.addAction'
-/

#print ULift.smulZeroClass /-
instance smulZeroClass [Zero M] [SMulZeroClass R M] : SMulZeroClass (ULift R) M :=
  { ULift.smulLeft with smul_zero := fun _ => smul_zero _ }
#align ulift.smul_zero_class ULift.smulZeroClass
-/

#print ULift.smulZeroClass' /-
instance smulZeroClass' [Zero M] [SMulZeroClass R M] : SMulZeroClass R (ULift M)
    where smul_zero c := by
    ext
    simp [smul_zero]
#align ulift.smul_zero_class' ULift.smulZeroClass'
-/

#print ULift.distribSmul /-
instance distribSmul [AddZeroClass M] [DistribSMul R M] : DistribSMul (ULift R) M
    where smul_add _ := smul_add _
#align ulift.distrib_smul ULift.distribSmul
-/

#print ULift.distribSmul' /-
instance distribSmul' [AddZeroClass M] [DistribSMul R M] : DistribSMul R (ULift M)
    where smul_add c f g := by
    ext
    simp [smul_add]
#align ulift.distrib_smul' ULift.distribSmul'
-/

#print ULift.distribMulAction /-
instance distribMulAction [Monoid R] [AddMonoid M] [DistribMulAction R M] :
    DistribMulAction (ULift R) M :=
  { ULift.mulAction, ULift.distribSmul with }
#align ulift.distrib_mul_action ULift.distribMulAction
-/

#print ULift.distribMulAction' /-
instance distribMulAction' [Monoid R] [AddMonoid M] [DistribMulAction R M] :
    DistribMulAction R (ULift M) :=
  { ULift.mulAction', ULift.distribSmul' with }
#align ulift.distrib_mul_action' ULift.distribMulAction'
-/

#print ULift.mulDistribMulAction /-
instance mulDistribMulAction [Monoid R] [Monoid M] [MulDistribMulAction R M] :
    MulDistribMulAction (ULift R) M
    where
  smul_one _ := smul_one _
  smul_mul _ := smul_mul' _
#align ulift.mul_distrib_mul_action ULift.mulDistribMulAction
-/

#print ULift.mulDistribMulAction' /-
instance mulDistribMulAction' [Monoid R] [Monoid M] [MulDistribMulAction R M] :
    MulDistribMulAction R (ULift M) :=
  {
    ULift.mulAction' with
    smul_one := fun _ => by
      ext
      simp [smul_one]
    smul_mul := fun c f g => by
      ext
      simp [smul_mul'] }
#align ulift.mul_distrib_mul_action' ULift.mulDistribMulAction'
-/

#print ULift.smulWithZero /-
instance smulWithZero [Zero R] [Zero M] [SMulWithZero R M] : SMulWithZero (ULift R) M :=
  { ULift.smulLeft with
    smul_zero := fun _ => smul_zero _
    zero_smul := zero_smul _ }
#align ulift.smul_with_zero ULift.smulWithZero
-/

#print ULift.smulWithZero' /-
instance smulWithZero' [Zero R] [Zero M] [SMulWithZero R M] : SMulWithZero R (ULift M)
    where
  smul_zero _ := ULift.ext _ _ <| smul_zero _
  zero_smul _ := ULift.ext _ _ <| zero_smul _ _
#align ulift.smul_with_zero' ULift.smulWithZero'
-/

#print ULift.mulActionWithZero /-
instance mulActionWithZero [MonoidWithZero R] [Zero M] [MulActionWithZero R M] :
    MulActionWithZero (ULift R) M :=
  { ULift.smulWithZero with }
#align ulift.mul_action_with_zero ULift.mulActionWithZero
-/

#print ULift.mulActionWithZero' /-
instance mulActionWithZero' [MonoidWithZero R] [Zero M] [MulActionWithZero R M] :
    MulActionWithZero R (ULift M) :=
  { ULift.smulWithZero' with }
#align ulift.mul_action_with_zero' ULift.mulActionWithZero'
-/

#print ULift.module /-
instance module [Semiring R] [AddCommMonoid M] [Module R M] : Module (ULift R) M :=
  { ULift.smulWithZero with add_smul := fun _ _ => add_smul _ _ }
#align ulift.module ULift.module
-/

#print ULift.module' /-
instance module' [Semiring R] [AddCommMonoid M] [Module R M] : Module R (ULift M) :=
  { ULift.smulWithZero' with add_smul := fun _ _ _ => ULift.ext _ _ <| add_smul _ _ _ }
#align ulift.module' ULift.module'
-/

#print ULift.moduleEquiv /-
/-- The `R`-linear equivalence between `ulift M` and `M`.
-/
@[simps apply symm_apply]
def moduleEquiv [Semiring R] [AddCommMonoid M] [Module R M] : ULift M ≃ₗ[R] M
    where
  toFun := ULift.down
  invFun := ULift.up
  map_smul' r x := rfl
  map_add' x y := rfl
  left_inv := by tidy
  right_inv := by tidy
#align ulift.module_equiv ULift.moduleEquiv
-/

end ULift


import algebraic_geometry.morphisms.universally_closed
import algebraic_geometry.morphisms.quasi_compact
import ring_theory.valuation.valuation_ring

noncomputable theory

open category_theory
open category_theory.morphism_property
open algebraic_geometry.morphism_property (topologically)
open algebraic_geometry.Scheme

universes u v

namespace category_theory

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

structure commutative_square :=
/-
tl ----> tr
|         |
|         |
bl ----> br
-/
{tl tr bl br : C} -- t for top; b for bottom; l for left; r for right
(v1 : tl ⟶ bl) (v2 : tr ⟶ br) (h1 : tl ⟶ tr) (h2 : bl ⟶ br)
(commutes : v1 ≫ h2 = h1 ≫ v2 . obviously)

variables {C}

def commutative_square.is_diagnol' (S : commutative_square C) (d : S.bl ⟶ S.tr) : Prop :=
  S.v1 ≫ d = S.h1 ∧ -- top triangle
  d ≫ S.v2 = S.h2

def commutative_square.exists_diagnol' (S : commutative_square C) : Prop :=
∃ (d : S.bl ⟶ S.tr), S.is_diagnol' d

def commutative_square.diagnol'_unique (S : commutative_square C) : Prop :=
∀ (d d' : S.bl ⟶ S.tr), S.is_diagnol' d → S.is_diagnol' d' → d = d'

end category_theory

structure valuative_pair :=
(ring_ : Type u) (fraction_field_ : Type u)
-- assumption on ring part
[is_comm_ring : comm_ring ring_]
[is_domain : is_domain ring_]
[is_valuation_ring : valuation_ring ring_]
-- assumption on fraction field part
[is_field : field fraction_field_]
[is_algebra : algebra ring_ fraction_field_]
[is_fractional : is_fraction_ring ring_ fraction_field_]

attribute [instance]
  valuative_pair.is_comm_ring
  valuative_pair.is_domain
  valuative_pair.is_valuation_ring
  valuative_pair.is_field
  valuative_pair.is_algebra
  valuative_pair.is_fractional

instance (P : valuative_pair) : algebra (CommRing.of P.ring_) (CommRing.of P.fraction_field_) := P.is_algebra
instance (P : valuative_pair) : is_domain (CommRing.of P.ring_) := P.is_domain
instance (P : valuative_pair) : valuation_ring (CommRing.of P.ring_) := P.is_valuation_ring
instance (P : valuative_pair) : local_ring (CommRing.of P.ring_) := valuation_ring.local_ring (CommRing.of P.ring_)

namespace Top

def specialization_lift_along : morphism_property Top.{u} :=
λ X Y g, ∀ ⦃y' y : Y⦄ (h : y' ⤳ y) (x' : X) (h' : g x' = y'), ∃ (x : X) (hx : x' ⤳ x), g x = y

-- **0064**
lemma specialization_lift_along.comp {X Y Z : Top.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)
  (hf : specialization_lift_along f) (hg : specialization_lift_along g) :
  specialization_lift_along $ f ≫ g :=
λ y' y h x' h',
begin
  obtain ⟨a, ha1, ha2⟩ := hg h (f x') h',
  obtain ⟨x, hx1, hx2⟩ := hf ha1 x' rfl,
  refine ⟨x, hx1, _⟩,
  rw [comp_apply, hx2, ha2],
end

-- **0066 a)**
lemma specialization_lift_along_of_closed {X Y : Top.{u}} (g : X ⟶ Y) (hg : is_closed_map g) :
  specialization_lift_along g :=
λ y' y hy x' hx',
begin
  let T : set X := closure {x'},
  have hT : is_closed T := is_closed_closure,
  let S : set Y := g '' T,
  have hS : is_closed S := hg _ hT,
  have y'_mem : g x' ∈ S := ⟨x', subset_closure (set.mem_singleton _), rfl⟩,
  rw hx' at y'_mem,
  obtain ⟨x, hx1, hx2⟩ := hy.mem_closed hS y'_mem,
  exact ⟨x, specializes_iff_mem_closure.mpr hx1, hx2⟩,
end

end Top

namespace algebraic_geometry

variables {X S : Scheme.{u}} (f : X ⟶ S)

def specialization_lift_along : morphism_property Scheme.{u} :=
λ X Y g, Top.specialization_lift_along g.1.base

def universally_specialization_lift_along : morphism_property Scheme.{u} :=
universally specialization_lift_along

-- **01KC a)**
lemma universally_specialization_lift_along_of_universally_closed [universally_closed f] :
  universally_specialization_lift_along f :=
λ X' S' i₁ i₂ f' H, Top.specialization_lift_along_of_closed _ $ universally_closed.out _ _ _ H

-- **01K9**
-- Need reduced induced strucutre of scheme
-- but this is fundamentally a topological question, so perhaps we don't have to be so fancy
lemma closed_iff_specialization_lift_along_of_quasi_compact [quasi_compact f] :
  is_closed_map f.1.base ↔ specialization_lift_along f :=
{ mp := λ h, Top.specialization_lift_along_of_closed _ h,
  mpr := sorry }

-- **01KC b)**
lemma universally_closed_of_quasicompact_and_universally_specialization_lift_along
  [quasi_compact f] (h1 : universally_specialization_lift_along f) :
  universally_closed f :=
{ out := λ X' Y' i₁ i₂ f' H,
  begin
    haveI : quasi_compact f' := quasi_compact_stable_under_base_change H.flip infer_instance,
    refine (closed_iff_specialization_lift_along_of_quasi_compact _).mpr (h1 _ _ _ H),
  end }

lemma universally_closed_iff_universally_specialization_lift_along_of_quasi_compact [quasi_compact f] :
  universally_closed f ↔ universally_specialization_lift_along f :=
⟨λ i, by exactI universally_specialization_lift_along_of_universally_closed f,
λ i, by exactI universally_closed_of_quasicompact_and_universally_specialization_lift_along f i⟩

alias category_theory.commutative_square ← commutative_square

def valuative_pair.Scheme_square (P : valuative_pair) ⦃X S : Scheme.{u}⦄ (f : X ⟶ S) (h1 h2 commutes) : commutative_square Scheme.{u} :=
{ v1 := Spec_map (algebra_map (CommRing.of P.ring_) (CommRing.of P.fraction_field_)),
  v2 := f,
  h1 := h1,
  h2 := h2 }

def valuative_pair.closed_point (P : valuative_pair) : (Spec_obj (CommRing.of P.ring_)).carrier :=
⟨_, ideal.is_maximal.is_prime' (local_ring.maximal_ideal _)⟩

lemma valuative_pair.closed_point_is_maximal_ideal (P : valuative_pair) :
  ideal.is_maximal P.closed_point.as_ideal :=
local_ring.maximal_ideal.is_maximal _

lemma valuative_pair.closed_point_is_closed (P : valuative_pair) : is_closed ({P.closed_point} : set $ (Spec_obj (CommRing.of P.ring_)).carrier) :=
begin
  rw prime_spectrum.is_closed_iff_zero_locus,
  refine ⟨P.closed_point.as_ideal, _⟩,
  rw ←prime_spectrum.closure_singleton,
  ext, simp only [set.mem_singleton_iff], split,
  { rintros rfl, refine subset_closure (set.mem_singleton _), },
  { intros h, rw ←prime_spectrum.le_iff_mem_closure at h,
    ext1, symmetry,
    refine ideal.is_maximal.eq_of_le P.closed_point_is_maximal_ideal x.is_prime.ne_top h, },
end

lemma valuative_pair.closed_point_unique
  (P : valuative_pair) {x : (Spec_obj (CommRing.of P.ring_)).carrier}
  (hx : is_closed ({x} : set $ (Spec_obj (CommRing.of P.ring_)).carrier)) :
  x = P.closed_point :=
begin
  rw prime_spectrum.is_closed_singleton_iff_is_maximal x at hx,
  ext : 1,
  convert local_ring.eq_maximal_ideal hx,
end

def valuative_pair.generic_point (P : valuative_pair) : (Spec_obj (CommRing.of P.ring_)).carrier :=
⟨⊥ , ideal.bot_prime⟩

lemma valuative_pair.generic_point_is_generic (P : valuative_pair) : is_generic_point P.generic_point set.univ :=
begin
  rw [is_generic_point_def, set.eq_univ_iff_forall],
  intros x,
  rw ←prime_spectrum.le_iff_mem_closure,
  exact bot_le,
end

lemma valuative_pair.generic_point_unique
  (P : valuative_pair) {x : (Spec_obj (CommRing.of P.ring_)).carrier}
  (hx : is_generic_point x set.univ) : x = P.generic_point :=
begin
  have h := hx.trans P.generic_point_is_generic.symm,
  have h1 := (prime_spectrum.le_iff_mem_closure x P.generic_point).mpr (h.symm ▸ subset_closure (set.mem_singleton _)),
  have h2 := (prime_spectrum.le_iff_mem_closure P.generic_point x).mpr (h ▸ subset_closure (set.mem_singleton _)),
  ext1,
  refine le_antisymm h1 h2,
end

-- **01J8 1)** but stacks says more
lemma morphisms_from_specialization {S : Scheme.{u}} {s' s : S.carrier} (hs : s' ⤳ s) :
  ∃ (P : valuative_pair) (f : Spec_obj (CommRing.of P.ring_) ⟶ S),
    (f : Spec_obj (CommRing.of P.ring_) ⟶ S).1.base P.generic_point = s' ∧
    (f : Spec_obj (CommRing.of P.ring_) ⟶ S).1.base P.closed_point = s := sorry

-- **01KD**
def valuative_criterion_existence_part : morphism_property Scheme.{u} :=
λ X S f, ∀ (P : valuative_pair) (h1 h2) (commutes),
  (P.Scheme_square f h1 h2 commutes).exists_diagnol'

-- **01KD**
def valuative_criterion_uniqueness_part : morphism_property Scheme.{u} :=
λ X S f, ∀ (P : valuative_pair) (h1 h2) (commutes), (P.Scheme_square f h1 h2 commutes).diagnol'_unique

-- **00KE**
lemma universally_specialization_lift_along_iff_valuative_criterion_existence_part :
  universally_specialization_lift_along f ↔ valuative_criterion_existence_part f :=
sorry

-- **01KF**
lemma valuative_criterion_for_universally_closedness [quasi_compact f] :
  universally_closed f ↔ valuative_criterion_existence_part f :=
(universally_closed_iff_universally_specialization_lift_along_of_quasi_compact f).trans $
universally_specialization_lift_along_iff_valuative_criterion_existence_part f

end algebraic_geometry


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.category_theory.eq_to_hom
import Mathlib.data.sigma.basic
import Mathlib.category_theory.pi.basic
import Mathlib.PostPort

universes w₁ v₁ u₁ l u₂ v₂ w₂ w₃

namespace Mathlib

/-!
# Disjoint union of categories

We define the category structure on a sigma-type (disjoint union) of categories.
-/

namespace category_theory

namespace sigma

/--
The type of morphisms of a disjoint union of categories: for `X : C i` and `Y : C j`, a morphism
`(i, X) ⟶ (j, Y)` if `i = j` is just a morphism `X ⟶ Y`, and if `i ≠ j` there are no such morphisms.
-/
inductive sigma_hom {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] :
    (sigma fun (i : I) => C i) → (sigma fun (i : I) => C i) → Type (max w₁ v₁ u₁)
    where
| mk : {i : I} → {X Y : C i} → (X ⟶ Y) → sigma_hom (sigma.mk i X) (sigma.mk i Y)

namespace sigma_hom

/-- The identity morphism on an object. -/
def id {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] (X : sigma fun (i : I) => C i) :
    sigma_hom X X :=
  sorry

protected instance inhabited {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) : Inhabited (sigma_hom X X) :=
  { default := id X }

/-- Composition of sigma homomorphisms. -/
def comp {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {X : sigma fun (i : I) => C i}
    {Y : sigma fun (i : I) => C i} {Z : sigma fun (i : I) => C i} :
    sigma_hom X Y → sigma_hom Y Z → sigma_hom X Z :=
  sorry

protected instance sigma.category_theory.category_struct {I : Type w₁} {C : I → Type u₁}
    [(i : I) → category (C i)] : category_struct (sigma fun (i : I) => C i) :=
  category_struct.mk id fun (X Y Z : sigma fun (i : I) => C i) (f : X ⟶ Y) (g : Y ⟶ Z) => comp f g

@[simp] theorem comp_def {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] (i : I)
    (X : C i) (Y : C i) (Z : C i) (f : X ⟶ Y) (g : Y ⟶ Z) : comp (mk f) (mk g) = mk (f ≫ g) :=
  rfl

theorem assoc {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) (Z : sigma fun (i : I) => C i)
    (W : sigma fun (i : I) => C i) (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W) : (f ≫ g) ≫ h = f ≫ g ≫ h :=
  sorry

theorem id_comp {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) (f : X ⟶ Y) : 𝟙 ≫ f = f :=
  sorry

theorem comp_id {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) (f : X ⟶ Y) : f ≫ 𝟙 = f :=
  sorry

end sigma_hom

protected instance sigma {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] :
    category (sigma fun (i : I) => C i) :=
  category.mk

/-- The inclusion functor into the disjoint union of categories. -/
@[simp] theorem incl_map {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] (i : I)
    (X : C i) (Y : C i) : ∀ (ᾰ : X ⟶ Y), functor.map (incl i) ᾰ = sigma_hom.mk ᾰ :=
  fun (ᾰ : X ⟶ Y) => Eq.refl (functor.map (incl i) ᾰ)

@[simp] theorem incl_obj {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {i : I}
    (X : C i) : functor.obj (incl i) X = sigma.mk i X :=
  rfl

protected instance incl.category_theory.full {I : Type w₁} {C : I → Type u₁}
    [(i : I) → category (C i)] (i : I) : full (incl i) :=
  full.mk fun (X Y : C i) (_x : functor.obj (incl i) X ⟶ functor.obj (incl i) Y) => sorry

protected instance incl.category_theory.faithful {I : Type w₁} {C : I → Type u₁}
    [(i : I) → category (C i)] (i : I) : faithful (incl i) :=
  faithful.mk

/--
To build a natural transformation over the sigma category, it suffices to specify it restricted to
each subcategory.
-/
def nat_trans {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    {F : (sigma fun (i : I) => C i) ⥤ D} {G : (sigma fun (i : I) => C i) ⥤ D}
    (h : (i : I) → incl i ⋙ F ⟶ incl i ⋙ G) : F ⟶ G :=
  nat_trans.mk fun (_x : sigma fun (i : I) => C i) => sorry

@[simp] theorem nat_trans_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] {F : (sigma fun (i : I) => C i) ⥤ D}
    {G : (sigma fun (i : I) => C i) ⥤ D} (h : (i : I) → incl i ⋙ F ⟶ incl i ⋙ G) (i : I) (X : C i) :
    nat_trans.app (nat_trans h) (sigma.mk i X) = nat_trans.app (h i) X :=
  rfl

/-- (Implementation). An auxiliary definition to build the functor `desc`. -/
def desc_map {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    (F : (i : I) → C i ⥤ D) (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) :
    (X ⟶ Y) →
        (functor.obj (F (sigma.fst X)) (sigma.snd X) ⟶
          functor.obj (F (sigma.fst Y)) (sigma.snd Y)) :=
  sorry

/--
Given a collection of functors `F i : C i ⥤ D`, we can produce a functor `(Σ i, C i) ⥤ D`.

The produced functor `desc F` satisfies: `incl i ⋙ desc F ≅ F i`, i.e. restricted to just the
subcategory `C i`, `desc F` agrees with `F i`, and it is unique (up to natural isomorphism) with
this property.

This witnesses that the sigma-type is the coproduct in Cat.
-/
@[simp] theorem desc_obj {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂}
    [category D] (F : (i : I) → C i ⥤ D) (X : sigma fun (i : I) => C i) :
    functor.obj (desc F) X = functor.obj (F (sigma.fst X)) (sigma.snd X) :=
  Eq.refl (functor.obj (desc F) X)

@[simp] theorem desc_map_mk {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂}
    [category D] (F : (i : I) → C i ⥤ D) {i : I} (X : C i) (Y : C i) (f : X ⟶ Y) :
    functor.map (desc F) (sigma_hom.mk f) = functor.map (F i) f :=
  rfl

/--
This shows that when `desc F` is restricted to just the subcategory `C i`, `desc F` agrees with
`F i`.
-/
-- We hand-generate the simp lemmas about this since they come out cleaner.

def incl_desc {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    (F : (i : I) → C i ⥤ D) (i : I) : incl i ⋙ desc F ≅ F i :=
  nat_iso.of_components (fun (X : C i) => iso.refl (functor.obj (incl i ⋙ desc F) X)) sorry

@[simp] theorem incl_desc_hom_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (i : I) (X : C i) :
    nat_trans.app (iso.hom (incl_desc F i)) X = 𝟙 :=
  rfl

@[simp] theorem incl_desc_inv_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (i : I) (X : C i) :
    nat_trans.app (iso.inv (incl_desc F i)) X = 𝟙 :=
  rfl

/--
If `q` when restricted to each subcategory `C i` agrees with `F i`, then `q` is isomorphic to
`desc F`.
-/
def desc_uniq {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    (F : (i : I) → C i ⥤ D) (q : (sigma fun (i : I) => C i) ⥤ D) (h : (i : I) → incl i ⋙ q ≅ F i) :
    q ≅ desc F :=
  nat_iso.of_components (fun (_x : sigma fun (i : I) => C i) => sorry) sorry

@[simp] theorem desc_uniq_hom_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (q : (sigma fun (i : I) => C i) ⥤ D)
    (h : (i : I) → incl i ⋙ q ≅ F i) (i : I) (X : C i) :
    nat_trans.app (iso.hom (desc_uniq F q h)) (sigma.mk i X) = nat_trans.app (iso.hom (h i)) X :=
  rfl

@[simp] theorem desc_uniq_inv_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (q : (sigma fun (i : I) => C i) ⥤ D)
    (h : (i : I) → incl i ⋙ q ≅ F i) (i : I) (X : C i) :
    nat_trans.app (iso.inv (desc_uniq F q h)) (sigma.mk i X) = nat_trans.app (iso.inv (h i)) X :=
  rfl

/--
If `q₁` and `q₂` when restricted to each subcategory `C i` agree, then `q₁` and `q₂` are isomorphic.
-/
@[simp] theorem nat_iso_inv {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂}
    [category D] {q₁ : (sigma fun (i : I) => C i) ⥤ D} {q₂ : (sigma fun (i : I) => C i) ⥤ D}
    (h : (i : I) → incl i ⋙ q₁ ≅ incl i ⋙ q₂) :
    iso.inv (nat_iso h) = nat_trans fun (i : I) => iso.inv (h i) :=
  Eq.refl (iso.inv (nat_iso h))

/-- A function `J → I` induces a functor `Σ j, C (g j) ⥤ Σ i, C i`. -/
def map {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₂} (g : J → I) :
    (sigma fun (j : J) => C (g j)) ⥤ sigma fun (i : I) => C i :=
  desc fun (j : J) => incl (g j)

@[simp] theorem map_obj {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₂}
    (g : J → I) (j : J) (X : C (g j)) : functor.obj (map C g) (sigma.mk j X) = sigma.mk (g j) X :=
  rfl

@[simp] theorem map_map {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₂}
    (g : J → I) {j : J} {X : C (g j)} {Y : C (g j)} (f : X ⟶ Y) :
    functor.map (map C g) (sigma_hom.mk f) = sigma_hom.mk f :=
  rfl

/--
The functor `sigma.map C g` restricted to the subcategory `C j` acts as the inclusion of `g j`.
-/
@[simp] theorem incl_comp_map_hom_app {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)]
    {J : Type w₂} (g : J → I) (j : J) (X : C (g j)) :
    nat_trans.app (iso.hom (incl_comp_map C g j)) X = 𝟙 :=
  Eq.refl 𝟙

/-- The functor `sigma.map` applied to the identity function is just the identity functor. -/
@[simp] theorem map_id_hom_app (I : Type w₁) (C : I → Type u₁) [(i : I) → category (C i)]
    (_x : sigma fun (i : I) => (fun (i : I) => (fun (i : I) => C (id i)) i) i) :
    nat_trans.app (iso.hom (map_id I C)) _x =
        nat_trans._match_1
          (fun (i : I) =>
            iso.hom
              (nat_iso.of_components (fun (X : C i) => iso.refl (sigma.mk i X))
                (map_id._proof_1 I C i)))
          _x :=
  sorry

/-- The functor `sigma.map` applied to a composition is a composition of functors. -/
@[simp] theorem map_comp_hom_app {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)]
    {J : Type w₂} {K : Type w₃} (f : K → J) (g : J → I)
    (X : sigma fun (i : K) => (fun (j : K) => function.comp C g (f j)) i) :
    nat_trans.app (iso.hom (map_comp C f g)) X =
        iso.hom
          (desc_uniq._match_1 (fun (j : K) => incl (g (f j))) (map (C ∘ g) f ⋙ map C g)
            (fun (k : K) =>
              iso_whisker_right (incl_comp_map (C ∘ g) f k) (map C g) ≪≫ incl_comp_map C g (f k))
            X) :=
  sorry

namespace functor

/--
Assemble an `I`-indexed family of functors into a functor between the sigma types.
-/
def sigma {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁}
    [(i : I) → category (D i)] (F : (i : I) → C i ⥤ D i) :
    (sigma fun (i : I) => C i) ⥤ sigma fun (i : I) => D i :=
  desc fun (i : I) => F i ⋙ incl i

end functor

namespace nat_trans

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def sigma {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁}
    [(i : I) → category (D i)] {F : (i : I) → C i ⥤ D i} {G : (i : I) → C i ⥤ D i}
    (α : (i : I) → F i ⟶ G i) : functor.sigma F ⟶ functor.sigma G :=
  nat_trans.mk
    fun (f : sigma fun (i : I) => C i) =>
      sigma_hom.mk (nat_trans.app (α (sigma.fst f)) (sigma.snd f))

end Mathlib


example (P : Prop) : ∀ {p : P}, P := by
  exact fun {p} => p

example (P : Prop) : ∀ {p : P}, P := by
  intro h; exact h

example (P : Prop) : ∀ {p : P}, P := by
  exact @id _

example (P : Prop) : ∀ {p : P}, P := by
  exact noImplicitLambda% id

macro "exact'" x:term : tactic => `(exact noImplicitLambda% $x)

example (P : Prop) : ∀ {p : P}, P := by
  exact' id

example (P : Prop) : ∀ {p : P}, P := by
  apply id

example (P : Prop) : ∀ p : P, P := by
  have : _ := 1
  apply id

example (P : Prop) : ∀ {p : P}, P := by
  refine noImplicitLambda% (have : _ := 1; ?_)
  apply id

example (P : Prop) : ∀ {p : P}, P := by
  have : _ := 1
  apply id


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 }


open classical

variables (α : Type) (p q : α → Prop)
variable r : Prop

example : α → ((∀ x : α, r) ↔ r) :=
  assume : α,
  ⟨λ h, h this, λ r x, r⟩
example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
  ⟨λ h,
     by_cases
       (λ hr, or.inr hr)
       (assume hnr : ¬r,
         or.inl
           (assume x : α,
             (h x).elim
               id
               (λ hr, absurd hr hnr))),
   λ h x, h.elim (λ f, or.inl (f x)) or.inr⟩
example : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
  ⟨λ h r x, h x r, λ h x r, h r x⟩


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Algdata.Data.List.Basic
import Algdata.Data.List.Prop

namespace List

/- Decidable LT -/
instance listHasDecidableLT (α : Type _) [LT α] [DecidableRel (α:=α) LT.lt] : DecidableRel (α:=List α) LT.lt
| _, [] => isFalse λ h => by cases h
| [], (_::_) => isTrue $ List.lt.nil _ _
| (a::as), (b::bs) =>
  if hab : a < b then
    isTrue $ List.lt.head _ _ hab
  else if hba : b < a then
    isFalse $ λ hcontra =>
      match hcontra with
      | List.lt.head _ _ h => hab h
      | List.lt.tail _ h _ => h hba
  else if hs : as < bs then
    isTrue $ List.lt.tail hab hba hs
  else
    isFalse $ λ hcontra =>
      match hcontra with
      | List.lt.head _ _ h => hab h
      | List.lt.tail _ _ h => hs h

/- Monad -/
instance instMonadList : Monad List where
  bind := List.bind
  pure a := [a]

/- LawfulMonad; i.e. monad laws -/
section LawfulMonad

variable {α β γ : Type _}

@[simp]
theorem pure_eq_singleton (a : α) : pure a = [a] := rfl

@[simp]
theorem map_eq_map (f : α → β) (as : List α) : f <$> as = as.map f := rfl

@[simp]
theorem bind_eq_bind (as : List α) (f : α → List β) : (as >>= f) = List.bind as f := rfl

@[simp]
theorem seq_eq_bind_map (fs : List (α → β)) (as : List α) : (fs <*> as) = List.bind fs as.map := rfl

@[simp]
theorem seqLeft_eq_bind_bind_const (as : List α) (bs : List β) : as <* bs = List.bind as (fun a => List.bind bs (Function.const β [a])):= rfl

@[simp]
theorem seqRight_eq_bind_const (as : List α) (bs : List β) : as *> bs = List.bind as (Function.const α bs) := rfl

@[simp]
theorem id_map (as : List α) : as.map id = as := by
  induction as with
  | nil => rfl
  | cons a as hi =>
    rw [map, hi]
    rfl

@[simp]
theorem bind_singleton_comp (f : α → β) : ∀ (as : List α), as.bind (fun a => [f a]) = as.map f
| [] => rfl
| (a::as) => by
  rw [cons_bind, map]
  rw [cons_append, nil_append]
  rw [bind_singleton_comp f as]

@[simp]
theorem singleton_bind (a : α) (f : α → List β) : [a].bind f = f a := by
  rw [List.bind, map, map, join, join]
  simp

@[simp]
theorem bind_assoc (as : List α) (f : α → List β) (g : β → List γ) : ((as.bind f).bind g) = as.bind fun x => (f x).bind g := by
  induction as with
  | nil => rfl
  | cons a as hi =>
    rw [cons_bind, cons_bind]
    rw [append_bind]
    rw [hi]

instance instLawfulMonadList : LawfulMonad List where
  id_map as := List.id_map as
  map_const := by intros; rfl
  seqLeft_eq {α} {β} as bs := by
    rw [seqLeft_eq_bind_bind_const]
    rw [seq_eq_bind_map]
    rw [map_eq_map]
    have : (fun (a : α) => bs.bind (Function.const _ [a])) = fun (a : α) => bs.map (Function.const _ a) := by
      apply funext; intro a
      rw [←bind_singleton_comp (Function.const β a) bs]
      rfl
    rw [this]; clear this
    rw [bind_map_binary_eq_map_bind_map]
  seqRight_eq as bs := by
    rw [seqRight_eq_bind_const]
    rw [seq_eq_bind_map]
    rw [map_eq_map]
    rw [←bind_map_binary_eq_map_bind_map]
    apply congrArg
    simp
    rfl
  pure_seq f as := by
    rw [seq_eq_bind_map]
    rw [pure_eq_singleton, map_eq_map]
    rw [singleton_bind]
  bind_pure_comp {α} {β} f as := by
    rw [bind_eq_bind]
    rw [funext (fun a=> pure_eq_singleton (f a))]
    rw [map_eq_map]
    rw [bind_singleton_comp]
  bind_map f as := by
    rw [bind_eq_bind]
    rw [funext (fun a=> map_eq_map a as)]
    rw [seq_eq_bind_map]
  pure_bind := singleton_bind
  bind_assoc := bind_assoc

end LawfulMonad

end List


/- LoVe Demo 7: Metaprogramming -/

import .lovelib

namespace LoVe

/- The Tactic Monad -/

example :
  true :=
by tactic.triv

example :
  true :=
by do
  tactic.trace "Hello, Metacosmos!",
  tactic.triv

meta def hello_world : tactic unit :=
do
  tactic.trace "Hello, Metacosmos!",
  tactic.triv

example :
  true :=
by hello_world

run_cmd tactic.trace "Hello, Metacosmos!"

open tactic

example (α : Type) (a : α) :
  true :=
by do
  trace "local context:",
  local_context >>= trace,
  trace "goals:",
  get_goals >>= trace,
  trace "target:",
  target >>= trace,
  triv

meta def exact_list : list expr → tactic unit
| []        := fail "no matching expression found"
| (e :: es) :=
  (do
     trace "trying ",
     trace e,
     exact e)
  <|> exact_list es

meta def find_assumption : tactic unit := do
  es ← local_context,
  exact_list es

example {p : Prop} {α : Type} (a : α) (h : p) :
  p :=
by do find_assumption

example {p : Prop} (h : p) :
  p :=
by do
  p_proof ← get_local `h,
  trace "p_proof:",
  trace p_proof,
  trace (expr.to_raw_fmt p_proof),
  trace "type of p_proof:",
  infer_type p_proof >>= trace,
  trace "type of type of p_proof:",
  infer_type p_proof >>= infer_type >>= trace,
  apply p_proof

/- Names and Expressions -/

#print expr

#check expr tt  -- elaborated expressions
#check expr ff  -- unelaborated expressions (pre-expressions)

#print name

#check (expr.const `ℕ [] : expr)
#check expr.sort level.zero  -- Sort 0, i.e., Prop
#check expr.sort (level.succ level.zero)
  -- Sort 1, i.e., Type 0 (Type)
#check expr.var 0  -- bound variable with De Bruijn index 0
#check (expr.local_const `uniq_name `pp_name binder_info.default
  `(ℕ) : expr)
#check (expr.mvar `uniq_name `pp_name `(ℕ) : expr)
#check (expr.pi `pp_name binder_info.default `(ℕ)
  (expr.sort level.zero) : expr)
#check (expr.lam `pp_name binder_info.default `(ℕ)
  (expr.var 0) : expr)
#check expr.elet
#check expr.macro

run_cmd do
  let e : expr := `(list.map (λn : ℕ, n + 1) [1, 2, 3]),
  trace e

run_cmd do
  let e : expr := `(list.map _ [1, 2, 3]),
    -- fails (holes are disallowed)
  skip

run_cmd do
  let e₁ : pexpr := ``(list.map (λn, n + 1) [1, 2, 3]),
  let e₂ : pexpr := ``(list.map _ [1, 2, 3]),
  trace e₁,
  trace e₂

run_cmd do
  let e := ```(some_silly_name),
  trace e

run_cmd trace `some.silly.name
run_cmd trace ``true
run_cmd trace ``some.silly.name  -- fails (not found)

run_cmd do
  let x : expr := `(2 : ℕ),
  let e : expr := `(%%x + 1),
  trace e

run_cmd do
  let x : expr := `(@id ℕ),
  let e := ``(list.map %%x),
  trace e

run_cmd do
  let x : expr := `(@id ℕ),
  let e := ```(a _ %%x),
  trace e

example :
  1 + 2 = 3 :=
by do
  `(%%a + %%b = %%c) ← target,
  trace a,
  trace b,
  trace c,
  `(@eq %%α %%l %%r) ← target,
  trace α,
  trace l,
  trace r,
  exact `(refl _ : 3 = 3)

/- A Simple Tactic: `destruct_and` -/

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

meta def destruct_and_helper : expr → expr → tactic unit
| `(%%a ∧ %%b) h :=
    exact h
    <|> (do
      ha ← to_expr ``(and.elim_left %%h),
      destruct_and_helper a ha)
    <|> (do
      hb ← to_expr ``(and.elim_right %%h),
      destruct_and_helper b hb)
| _            h := exact h

meta def destruct_and (nam : name) : tactic unit :=
do
  h ← get_local nam,
  t ← infer_type h,
  destruct_and_helper t h

example {a b c d : Prop} (h : a ∧ b ∧ c) :
  a :=
by destruct_and `h

example {a b c d : Prop} (h : a ∧ b ∧ c) :
  c :=
by destruct_and `h

example {a b c d : Prop} (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and `h

example {a b c d : Prop} (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h  -- fails

/- Example: A Solvability Advisor -/

meta def is_theorem : declaration → bool
| (declaration.defn _ _ _ _ _ _) := ff
| (declaration.thm _ _ _ _)      := tt
| (declaration.cnst _ _ _ _)     := ff
| (declaration.ax _ _ _)         := tt

meta def get_all_theorems : tactic (list name) :=
do
  env ← get_env,
  pure (environment.fold env [] (λdecl nams,
    if is_theorem decl then declaration.to_name decl :: nams
    else nams))

meta def solve_with_name (nam : name) : tactic unit :=
do
  cst ← mk_const nam,
  apply cst
    ({ md := transparency.reducible, unify := ff } : apply_cfg),
  all_goals assumption

meta def solve_direct : tactic unit :=
do
  nams ← get_all_theorems,
  list.mfirst (λnam,
    do
      solve_with_name nam,
      trace ("directly solved by " ++ to_string nam))
    nams

example {x y : ℕ} (h : x = y) :
  y = x :=
by solve_direct

meta def solve_direct_symm : tactic unit :=
solve_direct
<|> (do
  cst ← mk_const `eq.symm,
  apply cst,
  solve_direct)

example {n : ℕ} :
  n + 0 = n :=
by solve_direct_symm

example {n : ℕ} :
  n = n + 0 :=
by solve_direct_symm

end LoVe


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import group_theory.perm.basic
import logic.equiv.set

/-!
# `equiv.perm.via_embedding`, a noncomputable analogue of `equiv.perm.via_fintype_embedding`.

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

variables {α β : Type*}

namespace equiv

namespace perm

variables (e : perm α) (ι : α ↪ β)

open_locale classical

/-- Noncomputable version of `equiv.perm.via_fintype_embedding` that does not assume `fintype` -/
noncomputable def via_embedding : perm β :=
extend_domain e (of_injective ι.1 ι.2)

lemma via_embedding_apply (x : α) : e.via_embedding ι (ι x) = ι (e x) :=
extend_domain_apply_image e (of_injective ι.1 ι.2) x

lemma via_embedding_apply_of_not_mem (x : β) (hx : x ∉ _root_.set.range ι) :
  e.via_embedding ι x = x :=
extend_domain_apply_not_subtype e (of_injective ι.1 ι.2) hx

/-- `via_embedding` as a group homomorphism -/
noncomputable def via_embedding_hom : perm α →* perm β:=
extend_domain_hom (of_injective ι.1 ι.2)

lemma via_embedding_hom_injective : function.injective (via_embedding_hom ι) :=
extend_domain_hom_injective (of_injective ι.1 ι.2)

end perm

end equiv


import GMLInit.Data.Basic

inductive HVal.{u} : Type u
| mk {α : Sort u} : α → HVal

protected def HVal.sort : HVal → Type _
| @mk α _ => α

protected def HVal.val : (a : HVal) → a.sort
| mk a => a

theorem HVal.eq_of_val_heq_val : {a b : HVal} → a.val ≅ b.val → a = b
| mk _, mk _, HEq.refl _ => Eq.refl _

theorem HVal.val_heq_val_of_eq : {a b : HVal} → a = b → a.val ≅ b.val
| mk _, mk _, Eq.refl _ => HEq.refl _

theorem HVal.eq_iff_val_heq_val (a b : HVal) : a = b ↔ a.val ≅ b.val :=
  ⟨HVal.val_heq_val_of_eq, HVal.eq_of_val_heq_val⟩

theorem HVal.proof_irrel : (a b : HVal.{0}) → a = b
| @mk a ha, @mk b hb =>
  have h : a = b := propext ⟨λ _ => hb, λ _ => ha⟩
  match a, b, h with
  | _, _, rfl => proofIrrel ha hb ▸ rfl