import tactic

open tactic expr

meta def add_nonneg_proof_aux (n : expr) (h : option name) : tactic unit :=
do pf ← mk_app `nat.zero_le [n],
   nm ← get_unused_name,
   note (h.get_or_else nm) none pf,
   skip

example (n : ℕ) : true :=
begin
  add_nonneg_proof_aux `(55) none,
end

-- Comentario: Al colocar el cursor al final de la primera línea de la
-- demostración se obtiene
--    n : ℕ,
--    _x : 0 ≤ 55
--    ⊢ true

namespace tactic
namespace interactive

setup_tactic_parser

meta def add_nonneg_proof (n : parse parser.pexpr) (h : parse ident?)
  : tactic unit :=
do n ← to_expr n,
   add_nonneg_proof_aux n h

meta def add_nonneg_proofs (l : parse pexpr_list) : tactic unit :=
do l ← l.mmap to_expr,
   l.mmap' (λ e, add_nonneg_proof_aux e none)

end interactive
end tactic

example (n : ℕ) : true :=
begin
  add_nonneg_proof 55 hx,
end

-- Comentario: Al colocar el cursor al final de la primera línea de la
-- demostración se obtiene
--    n : ℕ,
--    hx : 0 ≤ 55
--    ⊢ true

example (n : ℕ) : true :=
begin
  add_nonneg_proof 55 hx,
  add_nonneg_proofs [n+n+n, 2*n^2],
end

-- Comentario: Al colocar el cursor al final de la primera línea de la
-- demostración se obtiene
--    n : ℕ,
--    hx : 0 ≤ 55,
--    _x : 0 ≤ n + n + n,
--    _x_1 : 0 ≤ 2 * n ^ 2
--    ⊢ true

meta def mk_list : tactic (list ℕ) :=
return [1, 4, 6]

run_cmd  do
  l ← mk_list,
  match l with
  | (h::t) := trace h
  | _      := failed
  end

-- Comentario: Al colocar el cursor sobre run_cmd se obtiene 1.

run_cmd  do
  [a, b, c] ← mk_list,
  trace b

-- Comentario: Al colocar el cursor sobre run_cmd se obtiene 4.

example : true ∧ true :=
by do
  split,
  gs ← get_goals,
  gs.mmap' trace

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ true
--
--    ⊢ true
--
--    ?m_1
--    ?m_1

example : true ∧ false :=
by do
  split,
  gs ← get_goals,
  gs.mmap' (λ e, do tp ← infer_type e, trace tp)

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ true
--
--    ⊢ false
--
--    true
--    false

example : true ∧ false :=
by do
  split,
  gs ← get_goals,
  gs.mmap' (λ e, trace e.to_raw_fmt)

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ true
--
--    ⊢ false
--
--    (mvar _mlocal._fresh.176.839 _mlocal._fresh.176.839 (const 2 []))
--    (mvar _mlocal._fresh.176.840 _mlocal._fresh.176.840 (const 2 []))

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  infer_type e1 >>= trace,
  infer_type e2 >>= trace

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ ?m_1 = ?m_1
--
--    ⊢ ℕ
--
--    ?m_1 = ?m_1
--    ℕ

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  infer_type e1 >>= trace,
  trace e1.to_raw_fmt,
  infer_type e2 >>= trace,
  trace e2.to_raw_fmt

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    2 goals
--    ⊢ ?m_1 = ?m_1
--
--    ⊢ ℕ
--
--    ?m_1 = ?m_1
--    (mvar _mlocal._fresh.215.1681 _mlocal._fresh.215.1681 (const 2 []))
--    ℕ
--    (mvar _mlocal._fresh.215.1680 _mlocal._fresh.215.1680 (const 2 []))

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  unify e2 `(7),
  trace e2

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    ⊢ 7 = 7
--
--    7

set_option pp.instantiate_mvars false

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  unify e2 `(7),
  trace e2,
  trace e2.to_raw_fmt

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    ⊢ ?m_1 = ?m_1
--
--    ?m_1
--    (mvar _mlocal._fresh.16.1433 _mlocal._fresh.16.1433 (const 2 []))

example : ∃ x : ℕ, x = x :=
by do
  applyc `exists.intro,
  [e1, e2] ← get_goals,
  unify e2 `(7),
  trace e2,
  trace e2.to_raw_fmt,
  e2 ← instantiate_mvars e2,
  trace e2.to_raw_fmt

-- Comentario: Al colocar el cursor sobre do se obtiene
--    tactic failed, there are unsolved goals
--    state:
--    ⊢ ?m_1 = ?m_1
--
--    ?m_1
--    (mvar _mlocal._fresh.54.1667 _mlocal._fresh.54.1667 (const 2 []))
--    (app
--     (app
--      (app
--       (app (const bit1 [0]) (const nat []))
--       (const nat.has_one [])) (const nat.has_add []))
--     (app
--      (app
--       (app
--        (app (const bit1 [0]) (const nat []))
--        (const nat.has_one []))
--       (const nat.has_add []))
--      (app
--       (app (const has_one.one [0]) (const nat []))
--       (const nat.has_one []))))

------------------------------------------------------------------------
-- § Referencia                                                       --
------------------------------------------------------------------------

-- Basado en el vídeo "Metaprogramming in Lean tutorial: video 6" de Rob
-- Lewis que se encuentra en https://youtu.be/ZbijjKFtvJI


import data.equiv.basic
import analysis.topology.topological_structures

def transport_topological_ring {α β : Type}
  [topological_space α] [ring α] [topological_ring α] (f : α ≃ β) : @topological_ring β sorry sorry := sorry

def transport_ring {α β : Type*} [ring α] (f : α ≃ β) : ring β :=
{ add := λ x y, f (f.symm x + f.symm y),
  zero := f 0,
  neg := λ x, f (-f.symm x),
  mul := λ x y, f (f.symm x * f.symm y),
  one := f 1,
  add_assoc := λ x y z, by simp; from add_assoc _ _ _,
  zero_add := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (zero_add _),
  add_zero := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (add_zero _),
  add_left_neg := λ x, by simp; from add_left_neg _,
  add_comm := λ x y, by simp; from add_comm _ _,
  mul_assoc := λ x y z, by simp; from mul_assoc _ _ _,
  one_mul := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (one_mul _),
  mul_one := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (mul_one _),
  left_distrib := λ x y z, by simp; from left_distrib _ _ _,
  right_distrib := λ x y z, by simp; from right_distrib _ _ _, }

import data.equiv
--import analysis.topology.topological_structures
universes u v

def transport_ring {α : Type u} {β : Type v} [ring α] (f : α ≃ β) : ring β :=
{ add := λ x y, f (f.symm x + f.symm y),
  zero := f 0,
  neg := λ x, f (-f.symm x),
  mul := λ x y, f (f.symm x * f.symm y),
  one := f 1,
  add_assoc := λ x y z, by simp; from add_assoc _ _ _,
  zero_add := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (zero_add _),
  add_zero := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (add_zero _),
  add_left_neg := λ x, by simp; from add_left_neg _,
  add_comm := λ x y, by simp; from add_comm _ _,
  mul_assoc := λ x y z, by simp; from mul_assoc _ _ _,
  one_mul := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (one_mul _),
  mul_one := λ x, by simp; from (equiv.apply_eq_iff_eq_inverse_apply _ _ _).2 (mul_one _),
  left_distrib := λ x y z, by simp; from left_distrib _ _ _,
  right_distrib := λ x y z, by simp; from right_distrib _ _ _, }

class transportable (f : Type u → Sort v) :=
(on_equiv : Π {α β : Type u} (e : equiv α β), equiv (f α) (f β))
(on_refl  : Π (α : Type u), on_equiv (equiv.refl α) = equiv.refl (f α))
(on_trans : Π {α β γ : Type u} (d : equiv α β) (e : equiv β γ), on_equiv (equiv.trans d e) = equiv.trans (on_equiv d) (on_equiv e))

#print topological_ring

#print sigma
-- Our goal is an automagic proof of the following
theorem group.transportable : transportable group := sorry
theorem topological_ring.transportable : transportable
  (λ R : (Σ (α : Type u), (topological_space α) × (ring α)) ,
    @topological_ring R.fst (R.snd).1 (R.snd).2) := sorry
#check topological_ring
-- These we might need to define and prove by hand
def Const : Type u → Type v := λ α, punit
def Fun : Type u → Type v → Type (max u v) := λ α β, α → β
def Prod : Type u → Type v → Type (max u v) := λ α β, α × β
def Swap : Type u → Type v → Type (max u v) := λ α β, β × α

lemma Const.transportable : (transportable Const) := {
  on_equiv := λ β γ H,⟨λ _,punit.star,λ _,punit.star,sorry,sorry⟩,
  on_refl := λ β,_,on_trans := λ β,_ }
lemma Fun.transportable (α : Type u) : (transportable (Fun α)) := sorry
lemma Prod.transportable (α : Type u) : (transportable (Prod α)) := sorry
lemma Swap.transportable (α : Type u) : (transportable (Swap α)) := sorry

-- And then we can define
def Hom1 (α : Type u) : Type v → Type (max u v) := λ β, α → β
def Hom2 (β : Type v) : Type u → Type (max u v) := λ α, α → β
def Aut : Type u → Type u := λ α, α → α

-- And hopefully automagically derive
lemma Hom1.transportable (α : Type u) : (transportable (Hom1 α)) := sorry
lemma Hom2.transportable (β : Type v) : (transportable (Hom1 β)) := sorry
lemma Aut.transportable (α : Type u) : (transportable Aut) := sorry

-- If we have all these in place...
-- A bit of magic might actually be able to derive `group.transportable` on line 11.
-- After all, a group just is a type plus some functions... and we can now transport functions.

structure equiv' (α : Type zfc_u) (β : Type zfc_u) :=
(i    : α → β)
(j    : β → α)
(ij : ∀ (x : α), j (i x) = x)
(ji  : ∀ (y : β), i (j y) = y)

definition mul_is_add {α : Type zfc_u} : equiv' (has_mul α) (has_add α) :=
{ i := λ ⟨mul⟩,⟨mul⟩,
  j := λ ⟨mul⟩,⟨mul⟩, -- didn't I just write that?
  ij := λ ⟨x⟩,rfl,
  ji := λ ⟨x⟩, rfl,  -- didn't I just write that?
}

definition : equiv'
definition equiv_mul {α β : Type zfc_u} : equiv' α β → equiv' (has_mul α) (has_mul β) := λ E,
{ i :=  λ αmul,⟨λ b1 b2, E.i (@has_mul.mul α αmul (E.j b1) (E.j b2))⟩,
  j := λ βmul,⟨λ a1 a2, E.j (@has_mul.mul β βmul (E.i a1) (E.i a2))⟩, -- didn't I just write that?
                                                                      -- should we introduce E-dual?
  ij := λ f, begin
    cases f, -- aargh why do I struggle
    suffices :  (λ (a1 a2 : α), E.j (E.i (f (E.j (E.i a1)) (E.j (E.i a2))))) = (λ a1 a2, f a1 a2),
      by rw this,
    funext,
    simp [E.ij,E.ji], -- got there in the end
  end,
  ji := -- I can't even do this in term mode so I just copy out the entire tactic mode proof again.
 λ g, begin
    cases g, -- aargh why do I struggle
    suffices :  (λ (b1 b2 : β), E.i (E.j (g (E.i (E.j b1)) (E.i (E.j b2))))) = (λ b1 b2, g b1 b2),
      by rw this,
    funext,
    simp [E.ij,E.ji], -- got there in the end
  end, -- didn't I just write that?
}

definition mul_to_add {α β : Type} : equiv' α β → equiv' (has_add α) (has_add β) := _ ∘ equiv_mul


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.category.Cat
import category_theory.groupoid
import category_theory.types

/-!
# Objects of a category up to an isomorphism

`is_isomorphic X Y := nonempty (X ≅ Y)` is an equivalence relation on the objects of a category.
The quotient with respect to this relation defines a functor from our category to `Type`.
-/

universes v u

namespace category_theory

section category

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

/-- An object `X` is isomorphic to an object `Y`, if `X ≅ Y` is not empty. -/
def is_isomorphic : C → C → Prop := λ X Y, nonempty (X ≅ Y)

variable (C)

/-- `is_isomorphic` defines a setoid. -/
def is_isomorphic_setoid : setoid C :=
{ r := is_isomorphic,
  iseqv := ⟨λ X, ⟨iso.refl X⟩, λ X Y ⟨α⟩, ⟨α.symm⟩, λ X Y Z ⟨α⟩ ⟨β⟩, ⟨α.trans β⟩⟩ }

end category

/--
The functor that sends each category to the quotient space of its objects up to an isomorphism.
-/
def isomorphism_classes : Cat.{v u} ⥤ Type u :=
{ obj := λ C, quotient (is_isomorphic_setoid C.α),
  map := λ C D F, quot.map F.obj $ λ X Y ⟨f⟩, ⟨F.map_iso f⟩ }

lemma groupoid.is_isomorphic_iff_nonempty_hom {C : Type u} [groupoid.{v} C] {X Y : C} :
  is_isomorphic X Y ↔ nonempty (X ⟶ Y) :=
(groupoid.iso_equiv_hom X Y).nonempty_congr

-- PROJECT: define `skeletal`, and show every category is equivalent to a skeletal category,
-- using the axiom of choice to pick a representative of every isomorphism class.
end category_theory


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen

! This file was ported from Lean 3 source module data.fun_like.embedding
! leanprover-community/mathlib commit c4658a649d216f57e99621708b09dcb3dcccbd23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.FunLike.Basic

/-!
# Typeclass for a type `F` with an injective map to `A ↪ B`

This typeclass is primarily for use by embeddings such as `RelEmbedding`.

## Basic usage of `EmbeddingLike`

A typical type of embeddings should be declared as:
```
structure MyEmbedding (A B : Type _) [MyClass A] [MyClass B] :=
(toFun : A → B)
(injective' : Function.Injective toFun)
(map_op' : ∀ {x y : A}, toFun (MyClass.op x y) = MyClass.op (toFun x) (toFun y))

namespace MyEmbedding

variables (A B : Type _) [MyClass A] [MyClass B]

-- This instance is optional if you follow the "Embedding class" design below:
instance : EmbeddingLike (MyEmbedding A B) A B :=
{ coe := MyEmbedding.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := MyEmbedding.injective' }

/-- Helper instance for when there's too many metavariables to `EmbeddingLike.coe` directly. -/
instance : CoeFun (MyEmbedding A B) (λ _, A → B) := ⟨MyEmbedding.toFun⟩

@[ext] theorem ext {f g : MyEmbedding A B} (h : ∀ x, f x = g x) : f = g := FunLike.ext f g h

/-- Copy of a `MyEmbedding` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : MyEmbedding A B) (f' : A → B) (h : f' = ⇑f) : MyEmbedding A B :=
{ toFun := f',
  injective' := h.symm ▸ f.injective',
  map_op' := h.symm ▸ f.map_op' }

end MyEmbedding
```

This file will then provide a `CoeFun` instance and various
extensionality and simp lemmas.

## Embedding classes extending `EmbeddingLike`

The `EmbeddingLike` design provides further benefits if you put in a bit more work.
The first step is to extend `EmbeddingLike` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
section

/-- `MyEmbeddingClass F A B` states that `F` is a type of `MyClass.op`-preserving embeddings.
You should extend this class when you extend `MyEmbedding`. -/
class MyEmbeddingClass (F : Type _) (A B : outParam <| Type _) [MyClass A] [MyClass B]
  extends EmbeddingLike F A B :=
(map_op : ∀ (f : F) (x y : A), f (MyClass.op x y) = MyClass.op (f x) (f y))

end

@[simp] lemma map_op {F A B : Type _} [MyClass A] [MyClass B] [MyEmbeddingClass F A B]
  (f : F) (x y : A) : f (MyClass.op x y) = MyClass.op (f x) (f y) :=
MyEmbeddingClass.map_op

-- You can replace `MyEmbedding.EmbeddingLike` with the below instance:
instance : MyEmbeddingClass (MyEmbedding A B) A B :=
{ coe := MyEmbedding.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := MyEmbedding.injective',
  map_op := MyEmbedding.map_op' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

The second step is to add instances of your new `MyEmbeddingClass` for all types extending
`MyEmbedding`.
Typically, you can just declare a new class analogous to `MyEmbeddingClass`:

```
structure CoolerEmbedding (A B : Type _) [CoolClass A] [CoolClass B]
  extends MyEmbedding A B :=
(map_cool' : toFun CoolClass.cool = CoolClass.cool)

section
set_option old_structure_cmd true

class CoolerEmbeddingClass (F : Type _) (A B : outParam <| Type _) [CoolClass A] [CoolClass B]
  extends MyEmbeddingClass F A B :=
(map_cool : ∀ (f : F), f CoolClass.cool = CoolClass.cool)

end

@[simp] lemma map_cool {F A B : Type _} [CoolClass A] [CoolClass B] [CoolerEmbeddingClass F A B]
  (f : F) : f CoolClass.cool = CoolClass.cool :=
MyEmbeddingClass.map_op

-- You can also replace `MyEmbedding.EmbeddingLike` with the below instance:
instance : CoolerEmbeddingClass (CoolerEmbedding A B) A B :=
{ coe := CoolerEmbedding.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  injective' := MyEmbedding.injective',
  map_op := CoolerEmbedding.map_op',
  map_cool := CoolerEmbedding.map_cool' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : MyEmbedding A B) : sorry := sorry
lemma do_something {F : Type _} [MyEmbeddingClass F A B] (f : F) : sorry := sorry
```

This means anything set up for `MyEmbedding`s will automatically work for `CoolerEmbeddingClass`es,
and defining `CoolerEmbeddingClass` only takes a constant amount of effort,
instead of linearly increasing the work per `MyEmbedding`-related declaration.

-/

/-- The class `EmbeddingLike F α β` expresses that terms of type `F` have an
injective coercion to injective functions `α ↪ β`.
-/
class EmbeddingLike (F : Sort _) (α β : outParam (Sort _)) extends FunLike F α fun _ ↦ β where
  /-- The coercion to functions must produce injective functions. -/
  injective' : ∀ f : F, @Function.Injective α β (coe f)
#align embedding_like EmbeddingLike

namespace EmbeddingLike

variable {F α β γ : Sort _} [i : EmbeddingLike F α β]

protected theorem injective (f : F) : Function.Injective f :=
  injective' f
#align embedding_like.injective EmbeddingLike.injective

@[simp]
theorem apply_eq_iff_eq (f : F) {x y : α} : f x = f y ↔ x = y :=
  (EmbeddingLike.injective f).eq_iff
#align embedding_like.apply_eq_iff_eq EmbeddingLike.apply_eq_iff_eq

@[simp]
theorem comp_injective {F : Sort _} [EmbeddingLike F β γ] (f : α → β) (e : F) :
    Function.Injective (e ∘ f) ↔ Function.Injective f :=
  (EmbeddingLike.injective e).of_comp_iff f
#align embedding_like.comp_injective EmbeddingLike.comp_injective

end EmbeddingLike


constant f : Nat → Nat
constant q : Nat → (Nat → Prop) → Nat

@[simp]
theorem ex {x : Nat} {p : Nat → Prop} (h₁ : p x) (h₂ : q x p = x) : f x = x :=
  sorry

set_option trace.Meta.Tactic.simp.discharge true
theorem foo : f (f x) = x := by
  simp
  sorry


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.AffineScheme
import ring_theory.nilpotent
import topology.sheaves.sheaf_condition.sites
import algebra.category.Ring.constructions
import ring_theory.local_properties

/-!
# Basic properties of schemes

We provide some basic properties of schemes

## Main definition
* `algebraic_geometry.is_integral`: A scheme is integral if it is nontrivial and all nontrivial
  components of the structure sheaf are integral domains.
* `algebraic_geometry.is_reduced`: A scheme is reduced if all the components of the structure sheaf
  is reduced.
-/

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

instance : t0_space X.carrier :=
begin
  refine t0_space.of_open_cover (λ x, _),
  obtain ⟨U, R, ⟨e⟩⟩ := X.local_affine x,
  let e' : U.1 ≃ₜ prime_spectrum R :=
    homeo_of_iso ((LocallyRingedSpace.forget_to_SheafedSpace ⋙ SheafedSpace.forget _).map_iso e),
  exact ⟨U.1.1, U.2, U.1.2, e'.embedding.t0_space⟩
end

instance : quasi_sober X.carrier :=
begin
  apply_with (quasi_sober_of_open_cover
    (set.range (λ x, set.range $ (X.affine_cover.map x).1.base)))
    { instances := ff },
  { rintro ⟨_,i,rfl⟩, exact (X.affine_cover.is_open i).base_open.open_range },
  { rintro ⟨_,i,rfl⟩,
    exact @@open_embedding.quasi_sober _ _ _
      (homeomorph.of_embedding _ (X.affine_cover.is_open i).base_open.to_embedding)
      .symm.open_embedding prime_spectrum.quasi_sober },
  { rw [set.top_eq_univ, set.sUnion_range, set.eq_univ_iff_forall],
    intro x, exact ⟨_, ⟨_, rfl⟩, X.affine_cover.covers x⟩ }
end

/-- A scheme `X` is reduced if all `𝒪ₓ(U)` are reduced. -/
class is_reduced : Prop :=
(component_reduced : ∀ U, _root_.is_reduced (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_reduced.component_reduced

lemma is_reduced_of_stalk_is_reduced [∀ x : X.carrier, _root_.is_reduced (X.presheaf.stalk x)] :
  is_reduced X :=
begin
  refine ⟨λ U, ⟨λ s hs, _⟩⟩,
  apply presheaf.section_ext X.sheaf U s 0,
  intro x,
  rw ring_hom.map_zero,
  change X.presheaf.germ x s = 0,
  exact (hs.map _).eq_zero
end

instance stalk_is_reduced_of_reduced [is_reduced X] (x : X.carrier) :
  _root_.is_reduced (X.presheaf.stalk x) :=
begin
  constructor,
  rintros g ⟨n, e⟩,
  obtain ⟨U, hxU, s, rfl⟩ := X.presheaf.germ_exist x g,
  rw [← map_pow, ← map_zero (X.presheaf.germ ⟨x, hxU⟩)] at e,
  obtain ⟨V, hxV, iU, iV, e'⟩ := X.presheaf.germ_eq x hxU hxU _ 0 e,
  rw [map_pow, map_zero] at e',
  replace e' := (is_nilpotent.mk _ _ e').eq_zero,
  erw ← concrete_category.congr_hom (X.presheaf.germ_res iU ⟨x, hxV⟩) s,
  rw [comp_apply, e', map_zero]
end

lemma is_reduced_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_reduced Y] : is_reduced X :=
begin
  constructor,
  intro U,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  exact is_reduced_of_injective (inv $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U))
    (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) : Y.presheaf.obj _ ≅ _).symm
      .CommRing_iso_to_ring_equiv.injective
end

instance {R : CommRing} [H : _root_.is_reduced R] : is_reduced (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_reduced_of_stalk_is_reduced { instances := ff },
  intro x, dsimp,
  haveI : _root_.is_reduced (CommRing.of $ localization.at_prime (prime_spectrum.as_ideal x)),
  { dsimp, apply_instance },
  exact is_reduced_of_injective (structure_sheaf.stalk_iso R x).hom
    (structure_sheaf.stalk_iso R x).CommRing_iso_to_ring_equiv.injective,
end

lemma affine_is_reduced_iff (R : CommRing) :
  is_reduced (Scheme.Spec.obj $ op R) ↔ _root_.is_reduced R :=
begin
  refine ⟨_, λ h, by exactI infer_instance⟩,
  intro h,
  resetI,
  haveI : _root_.is_reduced (LocallyRingedSpace.Γ.obj (op $ Spec.to_LocallyRingedSpace.obj $ op R)),
  { change _root_.is_reduced ((Scheme.Spec.obj $ op R).presheaf.obj $ op ⊤), apply_instance },
  exact is_reduced_of_injective (to_Spec_Γ R)
    ((as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv.injective)
end

lemma is_reduced_of_is_affine_is_reduced [is_affine X]
  [h : _root_.is_reduced (X.presheaf.obj (op ⊤))] : is_reduced X :=
begin
  haveI : is_reduced (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_reduced_iff, exact h },
  exact is_reduced_of_open_immersion X.iso_Spec.hom,
end

/-- To show that a statement `P` holds for all open subsets of all schemes, it suffices to show that
1. In any scheme `X`, if `P` holds for an open cover of `U`, then `P` holds for `U`.
2. For an open immerison `f : X ⟶ Y`, if `P` holds for the entire space of `X`, then `P` holds for
  the image of `f`.
3. `P` holds for the entire space of an affine scheme.
-/
lemma reduce_to_affine_global (P : ∀ (X : Scheme) (U : opens X.carrier), Prop)
  (h₁ : ∀ (X : Scheme) (U : opens X.carrier),
    (∀ (x : U), ∃ {V} (h : x.1 ∈ V) (i : V ⟶ U), P X V) → P X U)
  (h₂ : ∀ {X Y} (f : X ⟶ Y) [hf : is_open_immersion f], ∃ {U : set X.carrier} {V : set Y.carrier}
    (hU : U = ⊤) (hV : V = set.range f.1.base), P X ⟨U, hU.symm ▸ is_open_univ⟩ →
      P Y ⟨V, hV.symm ▸ hf.base_open.open_range⟩)
  (h₃ : ∀ (R : CommRing), P (Scheme.Spec.obj $ op R) ⊤) :
  ∀ (X : Scheme) (U : opens X.carrier), P X U :=
begin
  intros X U,
  apply h₁,
  intro x,
  obtain ⟨_, ⟨j, rfl⟩, hx, i⟩ := X.affine_basis_cover_is_basis.exists_subset_of_mem_open
    (set_like.mem_coe.2 x.prop) U.is_open,
  let U' : opens _ := ⟨_, (X.affine_basis_cover.is_open j).base_open.open_range⟩,
  let i' : U' ⟶ U :=
    hom_of_le i,
  refine ⟨U', hx, i', _⟩,
  obtain ⟨_,_,rfl,rfl,h₂'⟩ := h₂ (X.affine_basis_cover.map j),
  apply h₂',
  apply h₃
end

lemma eq_zero_of_basic_open_eq_bot {X : Scheme} [hX : is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj (op U)) (hs : X.basic_open s = ⊥) :
  s = 0 :=
begin
  apply Top.presheaf.section_ext X.sheaf U,
  simp_rw ring_hom.map_zero,
  unfreezingI { revert X U hX s },
  refine reduce_to_affine_global _ _ _ _,
  { intros X U hx hX s hs x,
    obtain ⟨V, hx, i, H⟩ := hx x,
    unfreezingI { specialize H (X.presheaf.map i.op s) },
    erw Scheme.basic_open_res at H,
    rw [hs] at H,
    specialize H inf_bot_eq ⟨x, hx⟩,
    erw Top.presheaf.germ_res_apply at H,
    exact H },
  { rintros X Y f hf,
    have e : (f.val.base) ⁻¹' set.range ⇑(f.val.base) = set.univ,
    { rw [← set.image_univ, set.preimage_image_eq _ hf.base_open.inj] },
    refine ⟨_, _, e, rfl, _⟩,
    rintros H hX s hs ⟨_, x, rfl⟩,
    unfreezingI { haveI := is_reduced_of_open_immersion f },
    specialize H (f.1.c.app _ s) _ ⟨x, by { rw [opens.mem_mk, e], trivial }⟩,
    { rw [← Scheme.preimage_basic_open, hs], ext1, simp [opens.map] },
    { erw ← PresheafedSpace.stalk_map_germ_apply f.1 ⟨_,_⟩ ⟨x,_⟩ at H,
      apply_fun (inv $ PresheafedSpace.stalk_map f.val x) at H,
      erw [category_theory.is_iso.hom_inv_id_apply, map_zero] at H,
      exact H } },
  { intros R hX s hs x,
    erw [basic_open_eq_of_affine', prime_spectrum.basic_open_eq_bot_iff] at hs,
    replace hs := (hs.map (Spec_Γ_identity.app R).inv),
    -- what the hell?!
    replace hs := @is_nilpotent.eq_zero _ _ _ _ (show _, from _) hs,
    rw iso.hom_inv_id_apply at hs,
    rw [hs, map_zero],
    exact @@is_reduced.component_reduced hX ⊤ }
end

@[simp]
lemma basic_open_eq_bot_iff {X : Scheme} [is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj $ op U) :
  X.basic_open s = ⊥ ↔ s = 0 :=
begin
  refine ⟨eq_zero_of_basic_open_eq_bot s, _⟩,
  rintro rfl,
  simp,
end

/-- A scheme `X` is integral if its carrier is nonempty,
and `𝒪ₓ(U)` is an integral domain for each `U ≠ ∅`. -/
class is_integral : Prop :=
(nonempty : nonempty X.carrier . tactic.apply_instance)
(component_integral : ∀ (U : opens X.carrier) [_root_.nonempty U],
  is_domain (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_integral.component_integral is_integral.nonempty

instance [h : is_integral X] : is_domain (X.presheaf.obj (op ⊤)) :=
@@is_integral.component_integral _ _ (by simp)

@[priority 900]
instance is_reduced_of_is_integral [is_integral X] : is_reduced X :=
begin
  constructor,
  intro U,
  cases U.1.eq_empty_or_nonempty with h h,
  { have : U = ⊥ := set_like.ext' h,
    haveI := CommRing.subsingleton_of_is_terminal (X.sheaf.is_terminal_of_eq_empty this),
    change _root_.is_reduced (X.sheaf.val.obj (op U)),
    apply_instance },
  { haveI : nonempty U := by simpa, apply_instance }
end

instance is_irreducible_of_is_integral [is_integral X] : irreducible_space X.carrier :=
begin
  by_contradiction H,
  replace H : ¬ is_preirreducible (⊤ : set X.carrier) := λ h,
    H { to_preirreducible_space := ⟨h⟩, to_nonempty := infer_instance },
  simp_rw [is_preirreducible_iff_closed_union_closed, not_forall, not_or_distrib] at H,
  rcases H with ⟨S, T, hS, hT, h₁, h₂, h₃⟩,
  erw not_forall at h₂ h₃,
  simp_rw not_forall at h₂ h₃,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ : opens X.carrier) := ⟨⟨_, h₂.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Tᶜ, hT.1⟩ : opens X.carrier) := ⟨⟨_, h₃.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ ⊔ ⟨Tᶜ, hT.1⟩ : opens X.carrier) :=
    ⟨⟨_, or.inl h₂.some_spec.some_spec⟩⟩,
  let e : X.presheaf.obj _ ≅ CommRing.of _ := (X.sheaf.is_product_of_disjoint ⟨_, hS.1⟩ ⟨_, hT.1⟩ _)
    .cone_point_unique_up_to_iso (CommRing.prod_fan_is_limit _ _),
  apply_with false_of_nontrivial_of_product_domain { instances := ff },
  { exact e.symm.CommRing_iso_to_ring_equiv.is_domain _ },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { ext x,
    split,
    { rintros ⟨hS,hT⟩,
      cases h₁ (show x ∈ ⊤, by trivial),
      exacts [hS h, hT h] },
    { intro x, exact x.rec _ } }
end

lemma is_integral_of_is_irreducible_is_reduced [is_reduced X] [H : irreducible_space X.carrier] :
  is_integral X :=
begin
  split, intros U hU,
  haveI := (@@LocallyRingedSpace.component_nontrivial X.to_LocallyRingedSpace U hU).1,
  haveI : no_zero_divisors
    (X.to_LocallyRingedSpace.to_SheafedSpace.to_PresheafedSpace.presheaf.obj (op U)),
  { refine ⟨λ a b e, _⟩,
    simp_rw [← basic_open_eq_bot_iff, ← opens.not_nonempty_iff_eq_bot],
    by_contra' h,
    obtain ⟨_, ⟨x, hx₁, rfl⟩, ⟨x, hx₂, e'⟩⟩ := @@nonempty_preirreducible_inter _ H.1
      (X.basic_open a).2 (X.basic_open b).2 h.1 h.2,
    replace e' := subtype.eq e',
    subst e',
    replace e := congr_arg (X.presheaf.germ x) e,
    rw [ring_hom.map_mul, ring_hom.map_zero] at e,
    refine zero_ne_one' (X.presheaf.stalk x.1) (is_unit_zero_iff.1 _),
    convert hx₁.mul hx₂,
    exact e.symm },
  exact no_zero_divisors.to_is_domain _
end

lemma is_integral_iff_is_irreducible_and_is_reduced :
  is_integral X ↔ irreducible_space X.carrier ∧ is_reduced X :=
⟨λ _, by exactI ⟨infer_instance, infer_instance⟩,
  λ ⟨_, _⟩, by exactI is_integral_of_is_irreducible_is_reduced X⟩

lemma is_integral_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_integral Y] [nonempty X.carrier] : is_integral X :=
begin
  constructor,
  intros U hU,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  haveI : is_domain (Y.presheaf.obj (op (H.base_open.is_open_map.functor.obj U))),
  { apply_with is_integral.component_integral { instances := ff },
    apply_instance,
    refine ⟨⟨_, _, hU.some.prop, rfl⟩⟩ },
  exact (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) :
    Y.presheaf.obj _ ≅ _).symm.CommRing_iso_to_ring_equiv.is_domain _
end

instance {R : CommRing} [H : is_domain R] : is_integral (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_integral_of_is_irreducible_is_reduced { instances := ff },
  { apply_instance },
  { dsimp [Spec.Top_obj],
    apply_instance },
end

lemma affine_is_integral_iff (R : CommRing) :
  is_integral (Scheme.Spec.obj $ op R) ↔ is_domain R :=
⟨λ h, by exactI ring_equiv.is_domain ((Scheme.Spec.obj $ op R).presheaf.obj _)
  (as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv, λ h, by exactI infer_instance⟩

lemma is_integral_of_is_affine_is_domain [is_affine X] [nonempty X.carrier]
  [h : is_domain (X.presheaf.obj (op ⊤))] : is_integral X :=
begin
  haveI : is_integral (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_integral_iff, exact h },
  exact is_integral_of_open_immersion X.iso_Spec.hom,
end

lemma map_injective_of_is_integral [is_integral X] {U V : opens X.carrier} (i : U ⟶ V)
  [H : nonempty U] :
  function.injective (X.presheaf.map i.op) :=
begin
  rw injective_iff_map_eq_zero,
  intros x hx,
  rw ← basic_open_eq_bot_iff at ⊢ hx,
  rw Scheme.basic_open_res at hx,
  revert hx,
  contrapose!,
  simp_rw [← opens.not_nonempty_iff_eq_bot, not_not],
  apply nonempty_preirreducible_inter U.is_open (RingedSpace.basic_open _ _).is_open,
  simpa using H
end

end algebraic_geometry


/-
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,
    intro 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

/--
Construct a left unitor from specified limit cones.
-/
@[simps]
def binary_fan.left_unitor
  {X : C} {s : cone (functor.empty 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 := 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 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 := 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 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 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


import exp.open
import .lc
import .subst

namespace tts ------------------------------------------------------------------
namespace exp ------------------------------------------------------------------
variables {V : Type} [decidable_eq V] -- Type of variable names
variables {v : V} -- Variable names
variables {k i : ℕ} -- Natural numbers
variables {x y : tagged V} -- Variable names
variables {e ex e₁ e₂ : exp V} -- Expressions
variables {L : finset (tagged V)} -- Variables sets

open occurs

@[simp] theorem subst_open_exp (lx : lc ex) :
  subst x ex (open_exp e₂ k e₁) = open_exp (subst x ex e₂) k (subst x ex e₁) :=
begin
  induction e₁ generalizing k,
  case exp.var : o y {
    cases o,
    { by_cases h : k = y.tag; simp [h] },
    { by_cases h : x = y; simp [h, open_exp_id lx] } },
  case exp.app : ef ea rf ra { simp [rf, ra] },
  case exp.lam : v eb rb { simp [rb] },
  case exp.let_ : v ed eb rd rb { simp [rd, rb] }
end

@[simp] theorem subst_open_exp₀ :
  lc ex → subst x ex (open_exp₀ e₂ e₁) = open_exp₀ (subst x ex e₂) (subst x ex e₁) :=
subst_open_exp

@[simp] theorem subst_open_var (lx : lc ex) (h : x ≠ y) :
  subst x ex (open_var y e₁) = open_var y (subst x ex e₁) :=
by simp [open_var, h, lx]

@[simp] theorem subst_open_fresh (lx : lc ex) (h : (fresh.tagged v).gen L ≠ x) :
  subst x ex (open_fresh v L e₁) = open_fresh v L (subst x ex e₁) :=
subst_open_var lx (ne.symm h)

/- subst_intro -/

theorem subst_intro : ∀ {e₁ : exp V} k,
  x ∉ fv e₁ → open_exp e₂ k e₁ = subst x e₂ (open_exp (var free x) k e₁)
| (var bound y)  k p := by by_cases h : k = y.tag; simp [h]
| (var free y)   k p := by simp at p; simp [p]
| (app ef ea)    k p := by simp at p; simp [subst_intro k p.1, subst_intro k p.2]
| (lam v eb)     k p := by simp at p; simp [subst_intro (k + 1) p]
| (let_ v ed eb) k p := by simp at p; simp [subst_intro k p.1, subst_intro (k + 1) p.2]

theorem subst_intro₀ : x ∉ fv e₁ → open_exp₀ e₂ e₁ = subst x e₂ (open_var x e₁) :=
subst_intro 0

-- Locally-closed expressions are stable over substitution
theorem subst_lc (x : tagged V) (lx : lc ex) (l : lc e) : lc (subst x ex e) :=
begin
  induction l generalizing ex lx x,
  case lc.var : y { by_cases h : x = y; simp [h, lx] },
  case lc.app : ef ea lf la rf ra { exact lc.app (rf lx x) (ra lx x) },
  case lc.lam : v L eb lb rb {
    apply lc.lam (L ∪ {x}),
    intros y Fy,
    simp [not_or_distrib] at Fy,
    rw ←subst_open_var lx (ne.symm Fy.2),
    exact rb Fy.1 lx x },
  case lc.let_ : v L ed eb ld lb rd rb {
    apply lc.let_ (L ∪ {x}) (rd lx x),
    intros y Fy,
    simp [not_or_distrib] at Fy,
    rw ←subst_open_var lx (ne.symm Fy.2),
    exact rb Fy.1 lx x }
end

theorem lc_open_exp₀ (v : V) (lb : lc_body e₁) (l₂ : lc e₂) : lc (open_exp₀ e₂ e₁) :=
begin
  cases lb with L l₁,
  have F : (fresh.tagged v).gen (L ∪ fv e₁) ∉ L ∧ (fresh.tagged v).gen (L ∪ fv e₁) ∉ fv e₁ :=
    (fresh.tagged v).gen_not_mem_union _ _,
  rw subst_intro₀ F.2,
  exact subst_lc _ l₂ (l₁ F.1)
end

end /- namespace -/ exp --------------------------------------------------------
end /- namespace -/ tts --------------------------------------------------------